使用 VBA 循环浏览文件夹中的所有 .txt 文件，然后将内容传输到 Excel 工作表

Question

这是基本代码（由@FaneDuru 共享）。这段代码工作得很好。它从 .txt 文件中读取数据并将前 160 列导入到 Excel 工作表中。此代码可以在多个文件上重复使用（进行数据导入和附加）。例如，我第一次运行此代码时，它会将所有数据从第一个选定的 .txt 文件导入到我的电子表格中。然后，如果我更改文件路径并再次运行它，它将忽略第二个文件的标题行（更准确地说，是除第一个选定文件之外的所有文件），并从第二个选定的 .txt 文件中追加所有数据到现有的 excel 工作表。

Private Sub CopyLessColumns() 'it copies less columns than the txt file has
 Dim strSpec As String, i As Long, colToRet As Long, lastR As Long
 Dim arrSp As Variant, arrRez() As String, arrInt As Variant, j As Long, k As Long
 Dim fso As Object, txtStr As Object, strText As String 'no need of any reference

  Set fso = CreateObject("Scripting.FileSystemObject")
  strSpec = " C:\Users\xxxxxx\Desktop\Forecast1.txt"
  If Dir(strSpec) <> "" Then 'check if file exists
    Set txtStr = fso.OpenTextFile(strSpec)
        strText = txtStr.ReadAll
    txtStr.Close
  End If
  arrSp = Split(strText, vbCrLf)

    colToRet = 160 'Number of columns to be returned
    lastR = ActiveSheet.Range("A" & Rows.count).End(xlUp).Row 'last row in A:A
    'arrRez is dimensioned from 0 to UBound(arrSp) only for lastR = 1
    ReDim arrRez(IIf(lastR = 1, 0, 1) To UBound(arrSp), colToRet - 1)
    For i = IIf(lastR = 1, 0, 1) To UBound(arrSp) 'Only in case of larR = 1, the
                                                  'head of the table is load in arr
      arrInt = Split(arrSp(i), vbTab)  'each strText line is split in an array
      If UBound(arrInt) > colToRet - 1 Then
          For j = 0 To colToRet - 1
              arrRez(i, j) = arrInt(j) 'each array element is loaded in the arrRez
          Next j
      End If
    Next i
    'The array is dropped in the dedicated range (calculated using Resize):
    ActiveSheet.Range("A" & IIf(lastR = 1, lastR, lastR + 1)).Resize(UBound(arrRez, 1), _
                                                UBound(arrRez, 2) + 1).Value = arrRez
End Sub

我要做的是将所有 .txt 文件存储到一个文件夹中，然后使用 vba 循环函数循环所有 .txt 文件并立即在它们上执行上面的代码。因此，每次我想在不同的 .txt 文件上运行此代码时，我都不必进入并更改文件路径。 这是我目前所拥有的：

Sub readFiles()
    Dim file As String, fileCount As Integer

    Dim filePath As String
    filePath = "C:\Users\xxxxxx\Desktop\Forecast" 
    file = Dir$(filePath)
    fileCount = 0

    While (Len(file) > 0)
        fileCount = fileCount + 1
        ReadTextFile filePath & file, fileCount
        file = Dir
    Wend
End Sub


Sub ReadTextFile(filePath As String, n As Integer)
 Dim strSpec As String, i As Long, colToRet As Long, lastR As Long
 Dim arrSp As Variant, arrRez() As String, arrInt As Variant, j As Long, k As Long
 Dim fso As FileSystemObject, txtStr As Object, strText As String                              

  Set fso = New FileSystemObject
  Set txtStr = fso.OpenTextFile(filePath, ForReading, False)

  Do While Not txtStr.AtEndOfStream
    arrSp = Split(strText, vbCrLf)

    colToRet = 160                                
        lastR = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row                     

        ReDim arrRez(IIf(lastR = 1, 0, 1) To UBound(arrSp), colToRet - 1)
        For i = IIf(lastR = 1, 0, 1) To UBound(arrSp) 
        arrInt = Split(arrSp(i), vbTab)  
        If UBound(arrInt) > colToRet - 1 Then
            For j = 0 To colToRet - 1
                arrRez(i, j) = arrInt(j) 
            Next j
             End If
     Next i

        ActiveSheet.Range("A" & IIf(lastR = 1, lastR, lastR + 1)).Resize(UBound(arrRez, 1), _
                                                UBound(arrRez, 2) + 1).Value = arrRez
    Loop

    txtStr.Close
End Sub

基本上，我正在尝试使用第一个 sub 循环遍历文件夹中的所有 .txt 文件，然后使用它们的路径作为函数参数调用第一个 sub。但它不以某种方式工作。 我不认为第一个（readFiles）子有什么问题……

在第二个子中，正如你在上面的代码中看到的，我替换了这部分基础代码

  Set fso = CreateObject("Scripting.FileSystemObject")
  strSpec = "C:\Teste VBA Excel\TextFileTabDel.txt"
  If Dir(strSpec) <> "" Then 'check if file exists
    Set txtStr = fso.OpenTextFile(strSpec)
        strText = txtStr.ReadAll
    txtStr.Close
  End If

用这个：

  Set fso = New FileSystemObject
  Set txtStr = fso.OpenTextFile(filePath, ForReading, False)

然后我将其余的基本代码放入一个 do while 循环中。

如果我运行 VBA 代码，我不会收到任何警告或错误迹象，但会弹出此消息框。但是如果我点击运行，什么都不会发生。

我真的不知道为什么这不起作用，所以任何 cmets/hints 将不胜感激！

Answer 1

我想出了如何以不同的方式解决问题。所以，我在这里为将来可能面临类似问题的人发布我的代码。

Sub Import()

Dim openfile As String

MsgBox "Please select a text file", vbOKOnly
strSpec = Application.GetOpenFilename("Textfiles (*.txt),*.txt", , "Open a textfile...")
Set fso = CreateObject("Scripting.FileSystemObject")

If Dir(strSpec) <> "" Then                              'check if file exists
    Set txtStr = fso.OpenTextFile(strSpec)
        strText = txtStr.ReadAll
    txtStr.Close
  End If

  arrSp = Split(strText, vbCrLf)

  colToRet = 160                                'Number of columns to be returned
    lastR = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row                      'last row in A:A
    'arrRez is dimensioned from 0 to UBound(arrSp) only for lastR = 1
    ReDim arrRez(IIf(lastR = 1, 0, 1) To UBound(arrSp), colToRet - 1)
    For i = IIf(lastR = 1, 0, 1) To UBound(arrSp) 'Only in case of larR = 1, the
                                                  'head of the table is load in arr
      arrInt = Split(arrSp(i), vbTab)  'each strText line is split in an array
      If UBound(arrInt) > colToRet - 1 Then
          For j = 0 To colToRet - 1
              arrRez(i, j) = arrInt(j) 'each array element is loaded in the arrRez
          Next j
      End If
    Next i
    'The array is dropped in the dedicated range (calculated using Resize):
    ActiveSheet.Range("A" & IIf(lastR = 1, lastR, lastR + 1)).Resize(UBound(arrRez, 1), _
                                                UBound(arrRez, 2) + 1).Value = arrRez


End Sub

您可以将此 VBA 代码链接到一个按钮，并在需要导入文本文件时单击该按钮。如果您不想进行覆盖而不是追加，请记住记录一个宏以擦除您在 Excel 工作表上已有的内容。