'******************************************
 '<< CODE FOR THISWORKBOOK MODULE >>
 
Option Explicit 
 
Private Sub Workbook_BeforeClose(Cancel As Boolean) 
     '//remove the right-click controls
    Run "RemoveFromMenu" 
End Sub 
 
 
 
Private Sub Workbook_Open() 
     
     '//remove any previous right-click controls
    Run "RemoveFromMenu" 
     
     '//now add new right-click controls
    With Application.CommandBars("Cell") 
        .Controls.Add(Type:=msoControlButton). _ 
        Caption = "Import text (column)" 
        .Controls.Add(Type:=msoControlButton). _ 
        Caption = "Import text (selection)" 
         
         '//assign procedures to these controls
        .Controls("Import text (column)"). _ 
        OnAction = "Import2NextCol" 
        .Controls("Import text (selection)"). _ 
        OnAction = "Import2ActiveCell" 
         
    End With 
     
End Sub 
 '******************************************
 
 
 
 '******************************************
 '<< CODE FOR STANDARD MODULE >>
 
Option Explicit 
 
Sub Import2ActiveCell() 
     
    Dim Filt$, Title$, FileText$, FileName$, N& 
     
     '//check that only one cell's been selected
    If Selection.Cells.Count > 1 Then 
        MsgBox "Please select one cell only", , "Starting-Point is Unclear..." 
        Exit Sub 
    End If 
     
     '//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) 
     
     '//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 = ActiveCell.Row 
        Do While Not EOF(1) 
            Input #1, FileText 
            Cells(N, ActiveCell.Column) = 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 imported text & exit sub
        ActiveCell.Select 
    End If 
End Sub 
 
 
 
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
    FirstEmpty = Cells.Find("*", SearchOrder:=xlByColumns, _ 
    LookIn:=xlValues, SearchDirection:=xlPrevious). _ 
    Column + 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) 
            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 
 
 
 
Private Sub RemoveFromMenu() 
    On Error Resume Next '< error = no controls
     
     '//remove right-click controls
    With Application.CommandBars("Cell") 
        .Controls("Import text (column)").Delete 
        .Controls("Import text (selection)").Delete 
    End With 
     
End Sub 
 '******************************************