更新VBA腳本來搜索子文件夾excel

Question

我以前得到了幫助，通過文件夾中的幾個文本文件進行閱讀並在電子表格中組織數據。我從@trincot得到了這個腳本，可以滿足我的需求。 How to import specific text from files in to excel?

Sub ReadFilesIntoActiveSheet() 
Dim fso As FileSystemObject 
Dim folder As folder, file As file, FileText As TextStream 
Dim TextLine As String 
Dim cl As Range 

Dim num As Long ' numerical part of key, as in "Ann:" 
Dim col As Long ' target column in Excel sheet 
Dim key As String ' Part before ":" 
Dim value As String ' Part after ":" 

' Get a FileSystem object 
Set fso = New FileSystemObject 

' Get the directory you want 
Set folder = fso.GetFolder("D:\YourDirectory\") 

' Set the starting point to write the data to 
' Don't write in first row where titles are 
Set cl = ActiveSheet.Cells(2, 1) 

' Loop thru all files in the folder 
For Each file In folder.Files 
    ' Open the file 
    Set FileText = file.OpenAsTextStream(ForReading) 

    ' Read the file one line at a time 
    Do While Not FileText.AtEndOfStream 

     TextLine = FileText.ReadLine 'read line 

     key = Split(TextLine & ":", ":")(0) 
     value = Trim(Mid(TextLine, Len(key)+2)) 
     num = Val(Mid(key,2)) 
     If num Then key = Replace(key, num, "") ' Remove number from key 
     col = 0 
     If key = "From" Then col = 1 
     If key = "Date" Then col = 2 
     If key = "A" Then col = 2 + num 
     If col Then 
      cl.Offset(, col-1).Value = value ' Fill cell 
     End If 
    Loop 

    ' Clean up 
    FileText.Close 
    ' Next row 
    Set cl = cl.Offset(1) 
Next file 
End Sub 

我想通了之後的問題是，我的TEXTFILES會在第一時間開始被存儲在一個子文件夾中的子文件夾，並且該腳本不寫入處理這種情況。

我通過@Cor_Blimey發現這個腳本在這裏Loop Through All Subfolders Using VBA

Public Sub NonRecursiveMethod() 
Dim fso, oFolder, oSubfolder, oFile, queue As Collection 

Set fso = CreateObject("Scripting.FileSystemObject") 
Set queue = New Collection 
queue.Add fso.GetFolder("your folder path variable") 'obviously replace 

Do While queue.Count > 0 
    Set oFolder = queue(1) 
    queue.Remove 1 'dequeue 
    '...insert any folder processing code here... 
    For Each oSubfolder In oFolder.SubFolders 
     queue.Add oSubfolder 'enqueue 
    Next oSubfolder 
    For Each oFile In oFolder.Files 
     '...insert any file processing code here... 
    Next oFile 
Loop 

End Sub 

而且兩個答案在這裏Loop through all subfolders and files under a folder and write the last modifed date information to an Excel spreadsheet通過@ L42和@克里斯尼爾森。

我也嘗試了一下TraversFolder function，但我還沒有能夠將這些解決方案合併到我現有的腳本中。任何幫助將非常感激！

Answer 1

把你的功能部分標有「又來了你的閱讀CODE 功能是我的我在項目中使用的一個。我刪除多餘的代碼，它應該做的事。

Sub index() 
ThisWorkbook.Save 
DoEvents 
Dim intResult As Integer 
Dim strPath As String 
Dim objFSO As Object 
Dim intCountRows As Integer 

Application.FileDialog(msoFileDialogFolderPicker).Title = "Vyberte prosím složku" 
Application.FileDialog(msoFileDialogFolderPicker).ButtonName = "Vybrat složku" 
Application.FileDialog(msoFileDialogFolderPicker).AllowMultiSelect = True 

intResult = Application.FileDialog(msoFileDialogFolderPicker).Show 
If intResult = 0 Then 
    End 
End If 
For Each Item In Application.FileDialog(msoFileDialogFolderPicker).SelectedItems 
     strPath = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1) 'ulož cestu ke složce 
     Set objFSO = CreateObject("Scripting.FileSystemObject") 
     intCountRows = GetAllFiles(strPath, ROW_FIRST, objFSO) 
     Call GetAllFolders(strPath, objFSO, intCountRows) 
Next Item 
End Sub 

Private Function GetAllFiles(ByVal strPath As String, ByVal intRow As Integer, ByRef objFSO As Object) As Integer 
DoEvents 
Dim objFolder As Object 
Dim objFile As Object 
Dim i As Integer 

i = intRow + 1 
Set objFolder = objFSO.GetFolder(strPath) 

For Each objFile In objFolder.Files 
     If Right(objFile.Name, 3) = "txt" Then 
        'HERE COMES YOU READING CODE 
        i = i + 1 
     End If 
Next objFile 
GetAllFiles = i + ROW_FIRST - 1 

End Function 

Private Sub GetAllFolders(ByVal strFolder As String, ByRef objFSO As Object, ByRef intRow As Integer) 
DoEvents 
Dim objFolder As Object 
Dim objSubFolder As Object 
Set objFolder = objFSO.GetFolder(strFolder) 
For Each objSubFolder In objFolder.subfolders 
     intRow = GetAllFiles(objSubFolder.Path, intRow, objFSO) 
     Call GetAllFolders(objSubFolder.Path, objFSO, intRow) 
Next objSubFolder 
End Sub