导入多个文本文件 Excel VBA

Question

我想将来自多个 .txt 文件的数据存储在 1 个工作表中。另外，我希望第一个单元格包含文件名而不是文件路径（如果可能），以便稍后将其链接到图表。数据中还有最多 7 列，而行数是可变的，每个额外的数组由一个空列分隔。

Dim myFile As String
Dim myValue As Integer
Dim rData As Integer
Dim Data As String
Dim LineArray() As String
Dim DataArray() As String
Dim TempArray() As String

Dim Delimiter As String
Dim row As Integer
Dim counter As Integer
Dim counterArrSep As Integer
Dim FileName As String





Sub Button1_Click()

'Input number of blades
myValue = InputBox("Please enter the number of employees below", "number of employees", vbOKCancel)

'Cancel (doesn't work properly)
If myValue = 0 Then
    Exit Sub
End If

'Inputs
Delimiter = " "
row = 1

'Populate the table
Do While counter < myValue

'.txt file processing

'Show open file dialog box
myFile = Application.GetOpenFilename()

'Cancel
If myFile = "False" Then
    Exit Sub
End If

'Get file name (doesn't work)
 FileName = Dir(myFile, vbDirectory)
 Dim DataArray()
 DataArray(counterArrSep, 0) = FileName

'Open file
rData = FreeFile
Open myFile For Input As rData

'Store file content inside a variable
Data = Input(LOF(rData), rData)

'Close file
Close rData

'Separate Out lines of data
LineArray() = Split(Data, vbCrLf)


'Read Data into an Array Variable
For x = LBound(LineArray) To UBound(LineArray)

    If Len(Trim(LineArray(x))) <> 0 Then

    'Split up line of text by delimiter
        TempArray = Split(LineArray(x), Delimiter)

    'Determine how many columns are needed
        col = UBound(TempArray)

    'Re-Adjust Array boundaries
    ReDim Preserve DataArray(col, row)

    'Load line of data into Array variable
        For y = LBound(TempArray) To UBound(TempArray)
            DataArray(y + counterArrSep, row) = TempArray(y)
    Next y
End If

'Next line
  row = row + 1

Next x

'Clear array
Erase TempArray

'Increments the count to get another file
counter = counter + 1

'Adds space between each arrays in the Worksheet
counterArrSep = counterArrSep + 8

Loop
End Sub

.txt 文件如下所示： ...\employees\John.txt

apples pears oranges carrots
4 5 34 2
43 5,5 4 43
6 54 9 7,5
41,5 55 0 2

...\employees\Steve.txt
apples pears oranges carrots cabbages
6 56 6 2 0
4 1 4 12 5
0 7 9 7 6
0 12 1 5 3
1 44 3 6 0
4 4 4,5 6 23

Answer 1

主子

Public Sub Main()
    Dim fd  As FileDialog
    Dim i   As Long

    Application.ScreenUpdating = False

    'set and determine file picker behaviour
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    fd.AllowMultiSelect = True

    'Launch file picker, exit if no files selected. Hold Ctrl to select multiple files.
    If Not fd.Show = -1 Then Exit Sub

    'Import selected files, file by file.
    For i = 1 To fd.SelectedItems.Count
        Call OpenFileForInput(fd.SelectedItems(i))
    Next i
End Sub

辅助子

Private Sub OpenFileForInput(ByVal FilePathAndName As String)
Dim DataInTransit   As String
Dim FileName        As String
Dim rData           As Integer
Dim Arr             As Variant

'extract the filename
FileName = StrReverse(Left(StrReverse(FilePathAndName), _
            InStr(1, StrReverse(FilePathAndName), "\") - 1))

rData = FreeFile
Open FilePathAndName For Input As #rData
    Do While Not EOF(rData)
        Line Input #rData, DataInTransit

        ' ##################################################
        ' This is where the data gets into the worksheet, line by line for each file.
        ' Modify to suit your needs
            DataInTransit = FileName & " " & DataInTransit
            Arr = Split(DataInTransit, " ")
            ActiveCell.Resize(1, UBound(Arr) + 1) = Split(DataInTransit, " ")
            ActiveCell.Offset(1).Activate
        ' ##################################################

    Loop
Close #rData
End Sub

我会选择不在数组上大量使用，而是将工作表范围视为数组。因此将该行直接粘贴到 ActiveCell 中，然后将 ActiveCell 移动到下一行。

我从我的一个旧项目中提取了代码，该项目将数十万行导入到工作表中。它在一分钟内完成，因此仍然相当快，尽管我导入每一行的方式并不优雅。

希望这会有所帮助。