Rekurencyjne odczytywanie nazw plików w folderze i jego pod folderach.   strona główna:
A po co ten Excel ;-)
 
Ostatnio znów dość częsty temat..  
A więc.. Mam folder a w nim trzy pliku xlsx i folder a w nim trzy pliki xlsx i folder … itd…. :-)  
Jak odczytać zawartość kom.A1 w ark.Arkusz1 ze wszystkich plików w moim folderze i jego pod folderach??  
 
całość:  
 
Option Explicit  
Dim colFilesFullNames As VBA.Collection  
   
Sub OdczytywaniePlików()  
   
On Error GoTo OdczytywaniePlików_Error  
    Dim i As Long  
      
    Const strArkName As String = "Arkusz1"  
    Const strRng As String = "A1"  
      
    PlikiZFolderu "C:\Users\MiTKuchta\Desktop\test", "*.xl*"  
   
    'For i = 1 To colFilesFullNames.Count  
        'Debug.Print colFilesFullNames(i)  
    'Next  
      
    Dim xlApp As Excel.Application, xlWkb As Excel.Workbook  
    Set xlApp = New Excel.Application  
   
    For i = 1 To colFilesFullNames.Count  
        Set xlWkb = xlApp.Workbooks.Open(CStr(colFilesFullNames(i)))  
        With xlWkb  
            Debug.Print .Worksheets(strArkName).Range(strRng), colFilesFullNames(i)  
        End With  
        xlWkb.Close SaveChanges:=False  
        Set xlWkb = Nothing  
    Next  
      
OdczytywaniePlików_Exit:  
    On Error Resume Next  
      
    If Not xlWkb Is Nothing Then  
        xlWkb.Close SaveChanges:=False  
        Set xlWkb = Nothing  
    End If  
      
    If Not xlApp Is Nothing Then  
        xlApp.Quit  
        Set xlApp = Nothing  
    End If  
      
    Set colFilesFullNames = Nothing  
    Exit Sub  
        
OdczytywaniePlików_Error:  
    MsgBox "Byk nr: - " & Err.Number & vbCrLf & vbCrLf & _  
             Err.Description, vbExclamation, "VBAProject - OdczytywaniePlików"  
    Resume OdczytywaniePlików_Exit  
   
End Sub  
   
Sub PlikiZFolderu(strFolderPath As String, strNameLike As String)  
    Dim objFSO As Object 'Scripting.FileSystemObject  
    Dim objFolder As Object 'Scripting.Folder  
    Dim objSubFolder As Object 'Scripting.Folder  
    Dim objFile As Object 'Scripting.File  
   
    Set objFSO = CreateObject("Scripting.FileSystemObject")  
    Set objFolder = objFSO.GetFolder(strFolderPath)  
      
    If colFilesFullNames Is Nothing Then Set colFilesFullNames = New VBA.Collection  
      
    For Each objFile In objFolder.Files  
        With objFile  
            If .Name Like strNameLike Then  
                colFilesFullNames.Add .Path, .Path  
            End If  
        End With  
    Next  
   
    For Each objSubFolder In objFolder.SubFolders  
        PlikiZFolderu objSubFolder.Path, strNameLike  
    Next  
   
    Set objFolder = Nothing  
    Set objFSO = Nothing  
End Sub  
 
Po kolei…  
 
Option Explicit  
Dim colFilesFullNames As VBA.Collection  
 
Procedura zapisze kolejne pełne nazwy (ścieżki) plików właśnie do tej kolekcji  
 
    Const strArkName As String = "Arkusz1"  
    Const strRng As String = "A1"  
 
Nazwa Arkusza i komórki z której dane będą odczytywane  
 
    PlikiZFolderu "C:\Users\MiTKuchta\Desktop\test", "*.xl*"  
 
Wywołanie procedury PlikiZFolderu. Argumentami są: ścieżka do folderu głównego i filtr nazw plików. "*.xl*" to wszelkie pliki Excela  
Procedura ta przez obiekt Scripting.FileSystemObject odczytuje w pętli nazwy plików dla danego folderu i umieszcza je w kolekcji.  
 
    Set objFSO = CreateObject("Scripting.FileSystemObject")  
    Set objFolder = objFSO.GetFolder(strFolderPath)  
      
    If colFilesFullNames Is Nothing Then Set colFilesFullNames = New VBA.Collection  
      
    For Each objFile In objFolder.Files  
        With objFile  
            If .Name Like strNameLike Then  
                colFilesFullNames.Add .Path, .Path  
            End If  
        End With  
    Next  
 
Następnie procedura wywołuje sama siebie ale dla wszystkich Folderów w tym folderze…  
 
    For Each objSubFolder In objFolder.SubFolders  
        PlikiZFolderu objSubFolder.Path, strNameLike  
    Next  
 
Po zakończeniu działania tej procedury wszystkie nazwy plików które są Like strNameLike są zapisane w kolekcji colFilesFullName  
Sam odczyt poszczególnych elementów tej kolekcji..  
 
    'For i = 1 To colFilesFullNames.Count  
        'Debug.Print colFilesFullNames(i)  
    'Next  
 
tu wykomenytowana bo to nie koniec zadania.  
 
    Dim xlApp As Excel.Application, xlWkb As Excel.Workbook  
    Set xlApp = New Excel.Application  
 
Tworzę nową, niewidoczną instancję Excela. Po co? Bo nie mogę zagwarantować że żaden plik z przeglądanych folderów nie ma  
nazwy takiej samej jak plik z którego startuję procedurę. A jak wiadomo w jednej instancji Excela nie mogą być otwarte dwa  
pliki o tej samej nazwie. W nowej instancji nie mam tego problemu. Jedyną konsekwencją zastosowania takiego rozwiązania  
jest konieczność stosowania obsługi błędów która w razie "w" zamknie otwierany plik i całą niewidoczną instancję.  
 
    For i = 1 To colFilesFullNames.Count  
        Set xlWkb = xlApp.Workbooks.Open(CStr(colFilesFullNames(i)))  
        With xlWkb  
            Debug.Print .Worksheets(strArkName).Range(strRng), colFilesFullNames(i)  
        End With  
        xlWkb.Close SaveChanges:=False  
        Set xlWkb = Nothing  
    Next  
 
Główna część - realizacja zadania. Dane zwracane do okna Immediate (VBE/Ctrl+G), Zawartość wskazanej komórki i nazwa pliku  
z którego dane czytamy  
 
W ramach obsługi błędów…  
 
OdczytywaniePlików_Exit:  
    On Error Resume Next  
      
    If Not xlWkb Is Nothing Then  
        xlWkb.Close SaveChanges:=False  
        Set xlWkb = Nothing  
    End If  
      
    If Not xlApp Is Nothing Then  
        xlApp.Quit  
        Set xlApp = Nothing  
    End If  
      
    Set colFilesFullNames = Nothing  
    Exit Sub  
        
OdczytywaniePlików_Error:  
    MsgBox "Byk nr: - " & Err.Number & vbCrLf & vbCrLf & _  
             Err.Description, vbExclamation, "VBAProject - OdczytywaniePlików"  
    Resume OdczytywaniePlików_Exit  
 
Wyniki w oknie Immediate na moim przykładowym folderze…  
 
 1            C:\Users\MiTKuchta\Desktop\Test\Zeszyt1.xlsx  
 2            C:\Users\MiTKuchta\Desktop\Test\Zeszyt2.xlsx  
 3            C:\Users\MiTKuchta\Desktop\Test\Zeszyt3.xlsx  
 1            C:\Users\MiTKuchta\Desktop\Test\tast1\Zeszyt1.xlsx  
 2            C:\Users\MiTKuchta\Desktop\Test\tast1\Zeszyt2.xlsx  
 3            C:\Users\MiTKuchta\Desktop\Test\tast1\Zeszyt3.xlsx  
 1            C:\Users\MiTKuchta\Desktop\Test\tast1\test2\Zeszyt1.xlsx  
 2            C:\Users\MiTKuchta\Desktop\Test\tast1\test2\Zeszyt2.xlsx  
 3            C:\Users\MiTKuchta\Desktop\Test\tast1\test2\Zeszyt3.xlsx