Excell VBA читает и записывает папку подкаталогов и ее файлы

Question

У меня есть папка, вложенные папки и ее файлы. Файлы называются Subfodlername-testType (11203-bcst). Я хочу взять данные из файлов во вложенной папке в соответствии с именем testType и записывать данные в excelform и сохранять автоматически. Сделайте это для всех подпапок с петлей. я могу сделать это с VBA?

Function Recurse(sPath As String) As String 

Dim FSO As New FileSystemObject 
Dim myFolder As Folder 
Dim mySubFolder As Folder 
Dim myFile As File 
Set myFolder = FSO.GetFolder(sPath) 
Dim s As String 

For Each mySubFolder In myFolder.SubFolders 
    For Each myFile In mySubFolder.Files 
     If InStr(myFile, "bcst") > 0 Then 

      Dim sItem2 As String 
      Dim sItem3 As String 
      Dim sItem4 As String 
      Dim sItem5 As String 
      Dim sItem6 As String 
      Dim sItem7 As String 


      Application.ScreenUpdating = False 
      Set ana = ThisWorkbook.Sheets("Sayfa1") 'Hangi sayfaya alınacak? 
      Set dosya = Workbooks.Open(sPath) 'Alınacak dosyanın uzantısı ne? 


      sItem2 = dosya.Sheets(ActiveSheet.Name).Range("A4") 
      Dim indexOfChar As Integer 
      indexOfChar = InStr(1, sItem2, ":") 
      Dim finalString As String 
      finalString = Right(sItem2, Len(sItem2) - indexOfChar) 
      ana.Range("F7") = finalString & "." 'Hangi sayfanın hangi hücresi nereye alınacak? 


      sItem3 = dosya.Sheets(ActiveSheet.Name).Range("A5") 
      Dim indexOfChar2 As Integer 
      indexOfChar2 = InStr(1, sItem3, ":") 
      Dim finalString2 As String 
      finalString2 = Right(sItem3, Len(sItem3) - indexOfChar2) 
      MsgBox finalString 
      ana.Range("F8") = finalString2 'Hangi sayfanın hangi hücresi nereye alınacak? 

      sItem4 = dosya.Sheets(ActiveSheet.Name).Range("A7") 
      Dim indexOfChar3 As Integer 
      indexOfChar3 = InStr(1, sItem4, ":") 
      Dim finalString3 As String 
      finalString3 = Right(sItem4, Len(sItem4) - indexOfChar3) 
      ana.Range("F9") = finalString3 'Hangi sayfanın hangi hücresi nereye alınacak? 

      sItem5 = dosya.Sheets(ActiveSheet.Name).Range("A6") 
      Dim indexOfChar4 As Integer 
      indexOfChar4 = InStr(1, sItem5, ":") 
      Dim finalString4 As String 
      finalString4 = Right(sItem5, Len(sItem5) - indexOfChar4) 
      ana.Range("F10") = finalString4 'Hangi sayfanın hangi hücresi nereye alınacak? 

      sItem6 = dosya.Sheets(ActiveSheet.Name).Range("A8") 
      Dim indexOfChar5 As Integer 
      indexOfChar5 = InStr(1, sItem6, ":") 
      Dim finalString5 As String 
      finalString5 = Right(sItem6, Len(sItem6) - indexOfChar5) 
      ana.Range("F11") = finalString5 'Hangi sayfanın hangi hücresi nereye alınacak? 


      sItem7 = dosya.Sheets(ActiveSheet.Name).Range("A11") 
      Dim indexOfChar6 As Integer 
      indexOfChar6 = InStr(1, sItem7, ":") 
      Dim finalString6 As String 
      finalString6 = Right(sItem7, Len(sItem7) - indexOfChar6) 
      ana.Range("F12") = finalString6 'Hangi sayfanın hangi hücresi nereye alınacak? 






      dosya.Close 
      Application.ScreenUpdating = True 

      Exit For 
     End If 
    Next 
    Recurse = Recurse(mySubFolder.Path) 
Next 

End Function 

---

Sub TestR() 

    Call Recurse(GetFolder) 

End Sub 

Answer 1

Что делать, если есть вложенные папки в ваших подпапок?

Попробуйте для зацикливания через файлы вместо:

Sub LoopFromFolder(ByVal folderName As String) 

    Dim file As Variant 

    For Each file In Filter(Split(CreateObject("WScript.Shell").Exec("CMD /C DIR """ & folderName & "\*.*"" /S /A:-D /B").StdOut.ReadAll, vbCrLf), "bcst") 
     '// Your code here 
    Next 
End Sub 

Это будет цикл через все файлы во всех вложенных папках folderName, которые содержат «bcst» в имени файла и гораздо быстрее, чем при использовании рекурсии с FileSystemObject