Ordner + Unterordner durchsuchen

Sub ImportTables()

    'Variabeln werden mit passenden Datentypen gesetzt  
    Dim wsTarget As Worksheet, wb As Workbook, fso As Object, rngOut As Range, f As String
    
    'Pfad in dem die *.xlsx Dateien liegen wird mit der Funktion fncBrowseForFolder ausgewählt  
    'andere Möglichkeit direkter Pfad angeben= (PATHFILES muss dann CONST gesetzt werden) "I:\Projects-Global\ITIS\IT37639_Logbuch_Zusammenfuehrung\090_Infos_Intern\Gleiche_Logbuecher_Test"  
    
    'Greif auf die Funktion fncBrowseForFolder zu um einen Ordner auszuwählen  
    PATHFILES = fncBrowseForFolder
    'Inputbox wird erstellt in der das Suchwort eingegeben werden soll  
    strFile = InputBox("Dateinamensteileingeben :" & Chr(13) & "z.B. Eingabe_*.xls")  
    
    'Führt das Makro schneller aus und unterdrückt Meldungen  
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    With ActiveSheet
        'erste Ausgabezelle in neuer .xlsx-Datei festlegen  
        Set rngOut = .Range("A5")  
        'hole die erste *.xlsx-Datei des Ordners  
        'Wenn nichts gefunden wird bleib f ="" --> While Bedingung ist nicht erfüllt und wird übersprungen  
        f = Dir(PATHFILES & "\" & strFile & ".xlsx")  
        'Loope solange bis alle Dateien verarbeitet wurden  
        Do While f <> ""  
            'öffne Datei  
            Set wb = Workbooks.Open(PATHFILES & "\" & f, ReadOnly:=True)  
            'kopiere den Inhalt der Tabelle in das aktuelle Sheet  
            With wb.Sheets(1)
                .Range("A29:N" & .Cells(Rows.Count, 4).End(xlUp).Row).Copy rngOut  
             End With
            'schließe Dokument wieder  
            wb.Close False
            'Ausgabezelle für den nächsten Import ermitteln  
            Set rngOut = .Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
            'hole Namen der nächsten Datei  
            f = Dir
        Loop
        '----Funktionsaufruf um Leere Spalten zu löschen------------------------------------------------------------------  
        deleteEmptyCells
        '------------------------------------------------------------------------  
        
        
    End With
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True

End Sub

' Öffnet das Suchfeld für die Ordnerauswahl  
Private Function fncBrowseForFolder(Optional ByVal defaultPath = "") As String  
  Dim objFlderItem As Object, objShell As Object, objFlder As Object
  
  Set objShell = CreateObject("Shell.Application") 'Vordefinierter Pfad einstellen zu Testzwecken (Standard--> DefaultPath)  
  Set objFlder = objShell.BrowseForFolder(0&, "Ordner auswählen...", 0&, "I:\Projects-Global\ITIS\IT37639_Logbuch_Zusammenfuehrung\090_Infos_Intern\Gleiche_Logbuecher_Test\")  
  
  If objFlder Is Nothing Then GoTo ErrExit
  
  Set objFlderItem = objFlder.Self
  fncBrowseForFolder = objFlderItem.Path
  
ErrExit:
  
  Set objShell = Nothing
  Set objFlder = Nothing
  Set objFlderItem = Nothing
End Function


Function deleteEmptyCells()
 Dim lngLetzte As Long
 Dim lngZeile As Long
 
 ' Bildschirmaktualisierung AUSschalten (Makro läuft schneller, Bildschirm flackert nicht)  
 Application.ScreenUpdating = False
 
 
 ' Letzte belegte Zelle in Spalte B plus 1 raussuchen und merken  
 lngLetzte = IIf(IsEmpty(Range("B65536")), Range("B65536").End(xlUp).Row + 1, 65536)  
 ' in einer Schleife von dieser Letzten bis Zeile 1 gehen - also von unten nach oben  
      For lngZeile = lngLetzte To 1 Step -1
    ' Wenn die Zelle in der ensprechenden Zeile in Spalte B leer ist  
        If Cells(lngZeile, 2) = "" Then  
    ' dann lösche die gesamte Zeile  
          Cells(lngZeile, 2).EntireRow.Delete
    ' Ende der Bedingung  
        End If
    ' Nächste Zeile mit der Bedingung vergleichen  
      Next
 ' Bildschirmaktualisierung EINschalten (nicht vergessen)  
 Application.ScreenUpdating = True
End Function

' **********************************************************************  
' Modul: Modul1 Typ: Allgemeines Modul  
' **********************************************************************  

Option Explicit

Sub DateienErmitteln()
  Dim objFiles() As Object, lngRet As Long, lngIndex As Long, lngRow As Long
  Dim strPath As String, strFile As String
  
  strPath = fncBrowseForFolder ' DateiPfad wird in die Text-Variable strPath kopiert  
  ' wenn strPath ungleich "" dann wird die Inputbox geöffnet  
  If strPath <> "" Then  
    strFile = InputBox("Dateinamensteileingeben :" & Chr(13) & "z.B. Eingabe_*.xls")  
    ' Wenn strFile ungleich "" dann ist wird die Funktion FileSearchINFO in lngRet geschrieben  
    If strFile <> "" Then  
      lngRet = FileSearchINFO(objFiles, strPath, strFile, True)
      'lngRet wird die Anzahl der gefundenen Daten gespeichert  
      If lngRet > 0 Then 'wenn Dateiname übereinstimmt gehts weiter  
        'Liefert die letzte Spalte von A zurück + 1  
        lngRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
        For lngIndex = 0 To lngRet - 1
          Cells(lngRow + lngIndex, 1) = strPath
          Cells(lngRow + lngIndex, 2) = objFiles(lngIndex).Name
          Cells(lngRow + lngIndex, 3) = objFiles(lngIndex).ParentFolder.Path
          Cells(lngRow + lngIndex, 4) = objFiles(lngIndex).DateCreated
        Next
      End If
    End If
  End If
End Sub

Private Function FileSearchINFO(ByRef Files() As Object, ByVal InitialPath As String, Optional ByVal FileName As String = "*", _  
    Optional ByVal SubFolders As Boolean = True) As Long
  
  '# PARAMETERINFO:  
  '# Files: Datenfeld zur Ausgabe der Suchergebnisse  
  '# InitialPath: String der das zu durchsuchende Verzeichnis angibt  
  '# FileName: String der den gesuchten Dateityp oder Dateinamen enthält (Optional, Standard="*.*" findet alle Dateien)  
  '# Beispiele: "*.txt" - Findet alle Textdateien  
  '# "*name*" - Findet alle Dateien mit "name" im Dateinamen  
  '# "*.avi;*.mpg" - Findet .avi und .mpg Dateien (Dateitypen mit ; trennen)  
  '# SubFolders: Boolean gibt an, ob Unterordner durchsucht werden sollen (Optional, Standard=False)  
  
  'Deklarierte Variablen werden erstellt  
  Dim fobjFSO As Object, ffsoFolder As Object, ffsoSubFolder As Object, ffsoFile As Object
  Dim intC As Integer, varFiles As Variant
  
  'Erstellt ein FileSystemObject das der Variablen fobjFSO zugeordnet wird  
  Set fobjFSO = CreateObject("Scripting.FileSystemObject")  
  ' Lädt eine Instanz eines vorhandenen Folder Objekts  
  Set ffsoFolder = fobjFSO.GetFolder(InitialPath)
  
  ' Bei einem Error springe zu ErrExit  
  On Error GoTo ErrExit
  ' Typ Long start:1; Zeichen:*; Gesucht:";" ; > 0 dann  
  If InStr(1, FileName, ";") > 0 Then  
    varFiles = Split(FileName, ";")  
  Else
    'Reserviert speicherplatz für neue Arrayvariable  
    ReDim varFiles(0)
    'Arrayvariable bekommt "*"  
    varFiles(0) = FileName
  End If
  'Leitet For Each ein; Group (ffsoFolder.Files) benötigt man fürs Statement  
  For Each ffsoFile In ffsoFolder.Files
    'Wenn im Object ffsoFile was drin ist dann gehts zur for schleife  
    If Not ffsoFile Is Nothing Then
    ' führt die schleife nur 1 mal aus  
      For intC = 0 To UBound(varFiles)
        
        If LCase(fobjFSO.GetFileName(ffsoFile)) Like LCase(varFiles(intC)) Then
          If IsArray(Files) Then
            ReDim Preserve Files(UBound(Files) + 1)
          Else
            ReDim Files(0)
          End If
          Set Files(UBound(Files)) = ffsoFile
          Exit For
        End If
      Next
    End If
  Next
  
  If SubFolders Then
    For Each ffsoSubFolder In ffsoFolder.SubFolders
      FileSearchINFO Files, ffsoSubFolder, FileName, SubFolders
    Next
  End If
  
  If IsArray(Files) Then FileSearchINFO = UBound(Files) + 1
ErrExit:
  Set fobjFSO = Nothing
  Set ffsoFolder = Nothing
End Function

' Öffnet das Suchfeld für die Ordnerauswahl  
Private Function fncBrowseForFolder(Optional ByVal defaultPath = "") As String  
  Dim objFlderItem As Object, objShell As Object, objFlder As Object
  
  Set objShell = CreateObject("Shell.Application")  
  Set objFlder = objShell.BrowseForFolder(0&, "Ordner auswählen...", 0&, defaultPath)  
  
  If objFlder Is Nothing Then GoTo ErrExit
  
  Set objFlderItem = objFlder.Self
  fncBrowseForFolder = objFlderItem.Path
  
ErrExit:
  
  Set objShell = Nothing
  Set objFlder = Nothing
  Set objFlderItem = Nothing
End Function