Snasui Excel Forum

Code: Select all

Sub Import2NextCol()

      Dim Filt$, Title$, FileText$
      Dim FileName$, N&, FirstEmpty&

      '//show dialog to import file
      '{Note: Office 2000 requires that
      '(*.bas; *.frm; *.cls;*.txt;*.log;*.frx)
      'be written twice, for later versions you
      'can delete the second instance}
      Filt = "VB Files (*.bas; *.frm; *.cls;*.txt;*.log;*.frx) " & _
             "(*.bas; *.frm; *.cls;*.txt;*.log;*.frx)," & _
             "*.bas;*.frm;*.cls;*.txt;*.log;*.frx"
      Title = "SELECT A FOLDER - DOUBLE-CLICK OR CLICK " & _
              "OPEN TO IMPORT - CANCEL TO QUIT"
      FileName = Application.GetOpenFilename _
                 (FileFilter:=Filt, FilterIndex:=5, Title:=Title)

      '//find first empty column
'      On Error GoTo IsBlankSheet    '< Error = nothing to find
      On Error Resume Next
      FirstEmpty = Cells.Find("*", SearchOrder:=xlByColumns, _
                              LookIn:=xlValues, SearchDirection:=xlPrevious). _
                   Column
      If FirstEmpty = 0 Then FirstEmpty = 1
      '//all columns contain text
      If FirstEmpty = 257 Then
            MsgBox "Sorry, no more columns on this sheet"
            Exit Sub
      End If

TextEntry:
      '//check there is a file to import
      If Dir(FileName) <> Empty Then
            '//import the text
            Application.ScreenUpdating = False
            Open (FileName) For Input As #1
            N = 1
            Do While Not EOF(1)
                 Line Input #1, FileText
                  Rows(N).Columns(FirstEmpty) = FileText
                  N = N + 1
            Loop      '< Loop until end of file
            Close #1

            '//tart up the spreadsheet
            ActiveWindow.DisplayGridlines = False
            With Cells
                  .Font.Size = 9
                  Columns.AutoFit
                  Rows.AutoFit
            End With

            '//goto the start of the entered text & exit sub
            Application.Goto Rows(1).Columns(FirstEmpty), scroll:=True
      End If
'      Exit Sub
'
'IsBlankSheet:
'      '//start in column 1
'      FirstEmpty = 1
'      '//clear the error & continue import
'      Resume TextEntry
End Sub

Code: Select all

Do While Not EOF(1)
      Input #1, FileText
      Rows(N).Columns(FirstEmpty) = FileText
      N = N + 1
Loop      '< Loop until end of file

Code: Select all

Do While Not EOF(1)
      Line Input #1, FileText '<== Change this line
      Rows(N).Columns(FirstEmpty) = FileText
      N = N + 1
Loop      '< Loop until end of file