Сделать из листов книгу

Public Function FileDialog_(ByVal Path As String, _
                            Optional MultiSelect As Boolean = True, _
                            Optional Expansion As String = "*.xlsm;*.xlsb;*.xlsx") As Variant
 
    Dim oFd    As FileDialog
    Dim s()    As Variant
    Dim lf     As Long
 
    Set oFd = Application.FileDialog(msoFileDialogFilePicker)
    With oFd     'используем короткое обращение к объекту
        .AllowMultiSelect = MultiSelect
        .Title = "Выбрать файлы:"     'заголовок окна диалога
        .Filters.Clear     'очищаем установленные ранее типы файлов
        .Filters.Add "Microsoft Excel Files", Expansion, 1     'устанавливаем возможность выбора только файлов Excel
        .InitialFileName = Path     'назначаем папку отображения и имя файла по умолчанию
        .InitialView = msoFileDialogViewDetails     'вид диалогового окна(доступно 9 вариантов)
        If .Show = 0 Then
            Call MsgBox("Не выбрано ни одного файла!", vbInformation, "Выбор файлов:")
            Exit Function     'показывает диалог
        End If
        ReDim Preserve s(1 To .SelectedItems.Count)
        For lf = 1 To .SelectedItems.Count
            s(lf) = CStr(.SelectedItems.Item(lf))     'считываем полный путь к файлу
        Next
    End With
    FileDialog_ = s
End Function

Private Function ReadTXTfile(ByVal FileName As String) As String
    Dim FSO    As Object
    Dim ts     As Object
    Set FSO = CreateObject("scripting.filesystemobject")
    Set ts = FSO.OpenTextFile(FileName, 1, True): ReadTXTfile = ts.ReadAll: ts.Close
    Set ts = Nothing: Set FSO = Nothing
End Function

Sub ImportTxt()
    Const StrPath As String = "Путь к папке с файлами"
    Dim StrFileVar() As Variant
 
    
    Dim i As Long
    
    StrFileVar = FileDialog_(StrPath, True)
        
    For i = 1 To UBound(StrFileVar)
        ThisWorkbook.Sheets.Add
        ActiveSheet.Name = Left(sGetBaseName(StrFileVar(i)), 31)
        Call SetTextIntoClipboard(ReadTXTfile(StrFileVar(i)))
        ActiveSheet.PasteSpecial
    Next i
    
End Sub
 
Public Function FileDialog_(ByVal Path As String, _
                            Optional MultiSelect As Boolean = True, _
                            Optional Expansion As String = "*.txt") As Variant
 
    Dim oFd    As FileDialog
    Dim s()    As Variant
    Dim lf     As Long
 
    Set oFd = Application.FileDialog(msoFileDialogFilePicker)
    With oFd     'используем короткое обращение к объекту
        .AllowMultiSelect = MultiSelect
        .Title = "Выбрать файлы:"     'заголовок окна диалога
        .Filters.Clear     'очищаем установленные ранее типы файлов
        .Filters.Add "Microsoft Excel Files", Expansion, 1     'устанавливаем возможность выбора только файлов Excel
        .InitialFileName = Path     'назначаем папку отображения и имя файла по умолчанию
        .InitialView = msoFileDialogViewDetails     'вид диалогового окна(доступно 9 вариантов)
        If .Show = 0 Then
            Call MsgBox("Не выбрано ни одного файла!", vbInformation, "Выбор файлов:")
Exit Function     'показывает диалог
        End If
        ReDim Preserve s(1 To .SelectedItems.Count)
        For lf = 1 To .SelectedItems.Count
            s(lf) = CStr(.SelectedItems.Item(lf))     'считываем полный путь к файлу
        Next
    End With
    FileDialog_ = s
End Function
 
Private Function ReadTXTfile(ByVal FileName As String) As String
    Dim FSO    As Object
    Dim ts     As Object
    Set FSO = CreateObject("scripting.filesystemobject")
    Set ts = FSO.OpenTextFile(FileName, 1, True): ReadTXTfile = ts.ReadAll: ts.Close
    Set ts = Nothing: Set FSO = Nothing
End Function
Public Function sGetBaseName(ByVal sPathFile As String) As String
    'sPathFile - строка, путь.
    'возвращает имя (без расширения) последнего компонента в заданном пути.
    Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    sGetBaseName = FSO.GetBaseName(sPathFile)
End Function
Public Sub SetTextIntoClipboard(ByVal txt As String)
    Dim MyDataObj As New DataObject
    MyDataObj.SetText txt
    MyDataObj.PutInClipboard
End Sub

private sub main
    dim p$, f$, t$, rw&, cl&, a()
    dim wb as object, ws as object, c as object
    
    p="c:\users\администратор\downloads\"
    f=dir(p+"*.txt"): if len(f)=0 then exit sub
    
    wb=thiscomponent: ws=wb.sheets(0)
    
    do
       open p+f for input as #1
            do while not eof(#1)
               line input #1, t
               a=split(t)
               for cl=0 to ubound(a)
                   c= ws.getcellbyposition(cl,rw)
                   select case cl
                       case 0 to 2, 5 to 7
                          c.setvalue(a(cl))
                       case else
                          c.setstring(a(cl)) 
                   end select
               next
               rw=rw+1
            loop
       close #1
       f=dir
    loop while len(f)
end sub

private sub main
    dim p$, f$, t$, rw&, cl&, a()
    dim wb as object, ws as object, c as object
    
    p="C:\Users\Gowan MTB\Desktop\EAR logs"
    f=dir(p+"*.txt"): if len(f)=0 then exit sub
    
    wb=thiscomponent: ws=wb.sheets(0)
    
    do
       open p+f for input as #1
            do while not eof(#1)
               line input #1, t
               a=split(t)
               for cl=0 to ubound(a)
                   c= ws.getcellbyposition(cl,rw)
                   select case cl
                       case 0 to 2, 5 to 7
                          c.setvalue(a(cl))
                       case else
                          c.setstring(a(cl)) 
                   end select
               next
               rw=rw+1
            loop
       close #1
       f=dir
    loop while len(f)
end sub