Excel VBA, чтобы выбрать папку и загрузить файлы TXT внутри

Пожалуйста, попробуйте следующий фрагмент кода. Он позволял вам выбрать папку для обработки, затем перебирать все существующие текстовые файлы, помещать их содержимое в массив, помещать содержимое в вычисленную последнюю строку и, наконец, применять TextToColumns. Он считает запятую разделителем столбцов:

Sub ProcessFilesFromChosenFolder()
  Dim textFileLocation As String, textDelimiter As String, fileName As String, arrTxt
  Dim ws As Worksheet, lastR As Long
  
  Set ws = Application.ActiveSheet 'use here the sheet you need
  textFileLocation = GetFolderName("This PC") 'if you need it to be open in a specific folder, place here its path
  
  fileName = Dir(textFileLocation & "\*.txt") 'first text file  name
  
  If fileName <> "" Then
    Do While fileName <> ""    'loop since there still are not processed text files
        'place the content of the text file in an array (split by VbCrLf):
        arrTxt = Split(CreateObject("Scripting.FileSystemObject").OpenTextFile(textFileLocation & "\" & fileName, 1).ReadAll, vbCrLf)
        lastR = ws.Range("A" & ws.rows.count).End(xlUp).row 'the row where to paste the array content

        'drop the transposed array content:
        ws.Range("A" & IIf(lastR = 1, lastR, lastR + 1)).Resize(UBound(arrTxt) + 1, 1).Value = Application.Transpose(arrTxt)
        
        fileName = Dir 'find the next text file
    Loop
  End If
  'apply TextToColumns to whole returned data:
  ws.Columns(1).TextToColumns Destination:=ws.Range("A1"), DataType:=xlDelimited, ConsecutiveDelimiter:=False, Comma:=True, _
             FieldInfo:=Array(Array(0, 1), Array(43, 1), Array(70, 1)), TrailingMinusNumbers:=True
End Sub

Function GetFolderName(InitPath As String) As String
    With Application.FileDialog(msoFileDialogFolderPicker)

        If InitPath <> "" Then
            If Right$(InitPath, 1) <> "\" Then
                InitPath = InitPath & "\"
            End If
            .InitialFileName = InitPath
        Else
            .InitialFileName = ""   'it starts at This PC...
        End If
        
        If .Show() = True Then
            If .SelectedItems.count > 0 Then
                GetFolderName = .SelectedItems(1)
            End If
        End If

    End With
End Function

Отредактировано:

В следующей версии не требуется TextToColumns, она разбивает каждую начальную строку массива по разделителю (запятой) и загружает третий финальный массив, чтобы удалить его содержимое после каждого обработанного текстового файла:

Sub ProcessFilesFromChosenFolderBis()
  Dim textFileLocation As String, fileName As String, ws As Worksheet, lastR As Long
  Dim arrTxt, arrLine, ColsNo As Long, arrFin, i As Long, j As Long
  Const textDelimiter As String = ","
  
  Set ws = Application.ActiveSheet 'use here the sheet you need
  textFileLocation = GetFolderName("This PC") 'if you need it to be open in a specific folder, place here its path
  
  fileName = Dir(textFileLocation & "\*.txt") 'first text file  name
  
  If fileName <> "" Then
    Do While fileName <> ""    'loop since there still are not processed text files
        'place the content of the text file in an array (split by VbCrLf):
        arrTxt = Split(CreateObject("Scripting.FileSystemObject").OpenTextFile(textFileLocation & "\" & fileName, 1).ReadAll, vbCrLf)
        ColsNo = UBound(Split(arrTxt(0), textDelimiter)) + 1 ' determine number of columns
        ReDim arrFin(1 To UBound(arrTxt) + 1, 1 To ColsNo)   'redim the aray to keep the processed data

        For i = 0 To UBound(arrTxt)
            arrLine = Split(arrTxt(i), textDelimiter) 'place each row/line in an array
            For j = 0 To UBound(arrLine): arrFin(i + 1, j + 1) = arrLine(j): Next j 'load final array
        Next i
        
        lastR = ws.Range("A" & ws.rows.count).End(xlUp).row 'the row where to paste the array content
        'drop the processed final array content:
        ws.Range("A" & IIf(lastR = 1, lastR, lastR + 1)).Resize(UBound(arrFin), UBound(arrFin, 2)).Value = arrFin
        
        fileName = Dir 'find the next text file
    Loop
  End If
  MsgBox "Ready..."
End Sub

Он использует ту же функцию для определения папки, подлежащей обработке.

Решение PowerQuery.

В Excel выберите «Данные» > «Получить данные» > «Из файла» > «Из папки»
.

В открывшемся диалоговом окне выберите папку, содержащую ваши текстовые файлы, и нажмите Transform Data.
.

Нажмите две стрелки вниз в столбце Content, чтобы развернуть данные.

Нажмите OK на следующем экране, чтобы импортировать данные.

Примените дальнейшие вычисления, чтобы получить нужные вам данные, и нажмите кнопку Close & Load, чтобы импортировать итоговую таблицу в Excel.

В PQ кнопка «Расширенный редактор» должна предоставить вам сценарий, подобный приведенному ниже. У вас также будет несколько вспомогательных запросов, созданных для вас PQ.

let
    Source = Folder.Files("H:\Test\Text Files"),
    #"Filtered Hidden Files1" = Table.SelectRows(Source, each [Attributes]?[Hidden]? <> true),
    #"Invoke Custom Function1" = Table.AddColumn(#"Filtered Hidden Files1", "Transform File", each #"Transform File"([Content])),
    #"Renamed Columns1" = Table.RenameColumns(#"Invoke Custom Function1", {"Name", "Source.Name"}),
    #"Removed Other Columns1" = Table.SelectColumns(#"Renamed Columns1", {"Source.Name", "Transform File"}),
    #"Expanded Table Column1" = Table.ExpandTableColumn(#"Removed Other Columns1", "Transform File", Table.ColumnNames(#"Transform File"(#"Sample File"))),
    #"Changed Type" = Table.TransformColumnTypes(#"Expanded Table Column1",{{"Source.Name", type text}, {"Attribute Name", type text}, {"Attribute Data", type text}, {"Units", Int64.Type}})
in
    #"Changed Type"

Теперь нам просто нужно добавить функцию, которая позволит нам изменить путь к файлу в первой строке запроса.

Создайте новый пустой запрос, используя Данные > Получить данные > Из других источников > Пустой запрос.
Добавьте этот код в запрос — он считывает значение из именованного диапазона. Я назвал этот запрос fGetNamedRange.

let GetNamedRange=(NamedRange) => 
    let
        name = Excel.CurrentWorkbook(){[Name=NamedRange]}[Content],
        value = name{0}[Column1]
    in
        value
in GetNamedRange  

Обновите первую строку исходного запроса. Я присвоил ячейке именованный диапазон MyFolderPath:

//Source = Folder.Files("H:\Test\Text Files"),
Source = Folder.Files(Text.From(fGetNamedRange("MyFolderPath"))),  

Последний шаг — добавить код VBA, который позволит вам обновить папку.

В обычный модуль добавьте этот код:

Public Function GetFolderName() As String

    Dim FD As FileDialog
    Set FD = Application.FileDialog(msoFileDialogFolderPicker)
    
    With FD
        .Title = "Select a Folder"
        .InitialFileName = ThisWorkbook.Path & Application.PathSeparator
        .AllowMultiSelect = False
        
        If .Show = -1 Then
            GetFolderName = .SelectedItems(1)
        End If
    End With
    
    Set FD = Nothing

End Function

В коде листа, где хранится путь к вашей папке:

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    If Target.Address = "$B$2" Then
        Cancel = True
        Target.Value2 = GetFolderName() & Application.PathSeparator
        
        If MsgBox("Refresh query?", vbYesNo + vbQuestion) = vbYes Then
            ThisWorkbook.Connections("Query - Text Files").Refresh 'NB - query is called "Text Files", but must add "Query - " in front of it.
        End If
    End If
End Sub