Datei Name und Pfad auslesen mit FSO Objekt

Option Compare Text 'benötigt für einen 'like' Vergleich  

Dim fso As Object 'Variable ganz am Anfang des Codefensters stehen lassen !  
Dim wb As Worksheet


Sub ImportTables()

    'Variabeln werden mit passenden Datentypen gesetzt  
     Dim rngOut As Range, f As Variant, objFoundFiles As New Collection, strFileFilter As String
    
    With ActiveSheet
        'erste Ausgabezelle in neuer .xlsx-Datei festlegen  
        Set rngOut = .Range("A2")  
        
        'Sheet ab Range-Paste vor Import gegebenenfalls bereinigen  
        If .UsedRange.Rows.Count >= rngOut.Row Then
            .Rows(rngOut.Row & ":" & .UsedRange.Rows.Count).Clear  
        End If
    End With
    
    'FilesystemObject erstellen  
     Set fso = CreateObject("Scripting.Filesystemobject")  

    '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  
    strFileFilter = InputBox("Dateinamensteileingeben :" & Chr(13) & "z.B. Eingabe_* (ohne Datei-Erweiterung, es werden nur *.xlsx, *.xlsm und *.xls Dateien gesucht)")  


    'Suche Dateien mit passenden Namen  

    enumFiles fso.GetFolder(PATHFILES), strFileFilter, objFoundFiles

    'Wenn Dateien gefunden wurden  
    If objFoundFiles.Count > 0 Then
        'Führt das Makro schneller aus und unterdrückt Meldungen  
        Application.ScreenUpdating = False
        Application.DisplayAlerts = False

        With ActiveSheet
            'Für jede gefundene Datei in der Collection  
            For Each f In objFoundFiles
                'öffne Datei  
                Set wb = Workbooks.Open(f, ReadOnly:=True).Sheets(1)
                 'Vergleiche Vorlage mit geöffneter Datei  
                 If .Range("A1").Value & .Range("B1").Value & .Range("C1").Value & .Range("D1").Value & .Range("E1").Value & .Range("F1").Value & .Range("G1").Value & .Range("H1").Value & .Range("I1").Value & .Range("J1").Value & .Range("K1").Value & .Range("L1").Value & .Range("M1").Value & .Range("N1").Value Like wb.Range("A28").Value & wb.Range("B28").Value & wb.Range("C28").Value & wb.Range("D28").Value & wb.Range("E28").Value & wb.Range("F28").Value & wb.Range("G28").Value & wb.Range("H28").Value & wb.Range("I28").Value & wb.Range("J28").Value & wb.Range("K28").Value & wb.Range("L28").Value & wb.Range("M28").Value & wb.Range("N28").Value Then  
                    'Kopiere A29:N Variable  
                    wb.Range("A29:N" & wb.Cells(Rows.Count, 1).End(xlUp).Row).Copy rngOut  
                End If
                'schließe Dokument wieder  
                wb.Parent.Close False
                'Ausgabezelle für den nächsten Import ermitteln  
                Set rngOut = .Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
            Next
            '----Funktionsaufruf um Leere Spalten zu löschen  
           deleteEmptyCells
            
        End With
        Application.ScreenUpdating = True
        Application.DisplayAlerts = True

    End If

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")  

  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 + 2, 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

'Funktion um Dateien rekursiv zu suchen  


Sub enumFiles(ByVal RootFolder As Object, ByVal strFilter As String, ByRef col As Collection)

    On Error Resume Next
    For Each file In RootFolder.Files
        ext = LCase(fso.GetExtensionName(file.Name))
        If fso.GetBasename(file.Name) Like strFilter And (ext = "xlsx" Or ext = "xls") Then  
            col.Add file.Path
        End If
    Next
    For Each subfolder In RootFolder.SubFolders
        enumFiles subfolder, strFilter, col
    Next

End Sub