Excel 2007 - Mehrere Excel-Dateien nach einem Wert duchsuchen und dazugeh. Daten abspeichern

Option Explicit
Option Compare Text

Const SuchPfad = "E:\Test"              'Monats-Mappen Ordnerpfad  
Const SuchSheet = "Tabelle1"            'Monats-Mappen Tabellenname  

Const NeueMappe = "E:\Test\Neu.xls"     'Neue Mappe Pfad  

Const StartZeile = 2                    'Neue Mappe Startzeile  

Const SuchSpalte = "U"                  'Monats-Mappen Spalte Suchen  
Const SucheVon = "200801"               'Monats-Mappen Von Mappe  
Const SucheBis = "200912"               'Monats-Mappen Bis Mappe  

Const Msg = "Der angegebene Ordner existiert nicht!"  

Sub GetExternData()
    Dim Wkb0 As Workbook, Wks0 As Worksheet, WksX As Worksheet, NextLine As Long, FirstAddress As String
    Dim Fso As Object, Folder As Object, File As Object, c As Range, Search As String
    
    Set Fso = CreateObject("Scripting.FileSystemObject")  
    
    If Fso.FolderExists(SuchPfad) = False Then MsgBox Msg, vbExclamation, "Fehler":  Exit Sub  
   
    Search = InputBox("Bitte Suchbegriff eingeben:", "Suchen")  
    
    If Search = "" Then Exit Sub  
    
    Workbooks.Add:  Set Wkb0 = ActiveWorkbook:  Set Wks0 = Wkb0.Sheets(1)
    
    Set Folder = Fso.GetFolder(SuchPfad)
    
    NextLine = StartZeile
    
    Application.ScreenUpdating = False
    
    For Each File In Folder.Files
        If LCase(Fso.GetExtensionName(File)) = "xls" And IsNumeric(Fso.GetBaseName(File)) = True Then  
            If Fso.GetBaseName(File) >= SucheVon And Fso.GetBaseName(File) <= SucheBis Then
                Set WksX = GetObject(File.Path).Sheets(SuchSheet)
                Set c = WksX.Columns(SuchSpalte).Find(Search, LookIn:=xlValues, LookAt:=xlPart)
                If Not c Is Nothing Then
                    FirstAddress = c.Address
                    Do: WksX.Rows(c.Row).Copy Destination:=Wks0.Cells(NextLine, 1)
                        NextLine = NextLine + 1
                        Set c = WksX.Columns(SuchSpalte).FindNext(c)
                    Loop While Not c Is Nothing And c.Address <> FirstAddress
                End If
                GetObject(File.Path).Close False
            End If
        End If
    Next
    
    Wkb0.SaveAs NeueMappe:  Wkb0.Close
    
    Application.ScreenUpdating = True
End Sub

Option Explicit
Option Compare Text

Const SuchPfad = "E:\Test"                      'Such-Ordnerpfad  
Const SuchFiles = "Inhaltsverzeichnis*.xls"     'Such-Dateien  
Const SuchSheet = "Tabelle1"                    'Such-Tabellenname  
Const SuchSpalte = "U"                          'Such-Spalte  

Const NeueMappe = "E:\Test\Neu.xls"             'Neue Mappe Pfad  
Const StartZeile = 2                            'Neue Mappe Startzeile  

Const Msg = "Der angegebene Ordner existiert nicht!"  

Sub GetExternData()
    Dim Wkb0 As Workbook, Wks0 As Worksheet, WksX As Worksheet, NextLine As Long, FirstAddress As String
    Dim Fso As Object, File As Object, c As Range, Search As String
    
    Set Fso = CreateObject("Scripting.FileSystemObject")  
    
    If Fso.FolderExists(SuchPfad) = False Then MsgBox Msg, vbExclamation, "Fehler":  Exit Sub  
   
    If Fso.FileExists(NeueMappe) = True Then Fso.DeleteFile NeueMappe

    Search = InputBox("Bitte Suchbegriff eingeben:", "Suchen")  
    
    If Search = "" Then Exit Sub  
    
    Workbooks.Add:  Set Wkb0 = ActiveWorkbook:  Set Wks0 = Wkb0.Sheets(1)
    
    NextLine = StartZeile
    
    Application.ScreenUpdating = False
    
    For Each File In Fso.GetFolder(SuchPfad).Files
        If File.Name Like SuchFiles Then
            Set WksX = GetObject(File.Path).Sheets(SuchSheet)
            Set c = WksX.Columns(SuchSpalte).Find(Search, LookIn:=xlValues, LookAt:=xlPart)
            If Not c Is Nothing Then
                FirstAddress = c.Address
                Do: WksX.Rows(c.Row).Copy Destination:=Wks0.Cells(NextLine, 1)
                    NextLine = NextLine + 1
                    Set c = WksX.Columns(SuchSpalte).FindNext(c)
                Loop While Not c Is Nothing And c.Address <> FirstAddress
            End If
            GetObject(File.Path).Close False
        End If
    Next
    
    Wkb0.SaveAs NeueMappe:  Wkb0.Close
    
    Application.ScreenUpdating = True
End Sub

Option Explicit
Option Compare Text

Const SuchPfad = "X:\Test"                'Such-Ordnerpfad  
Const SuchName = "*.xls*"                 'Such-Dateien (Wildcards erlaubt)  

Const SuchSpalte = "A"                    'Such-Spalte  

Const NeueMappe = "X:\Test\Ergebnis"      'Neue Mappe Pfad (ohne .xls/.xlsx)  

Const TitelZeile = "Dateiname,Produkt,Suchbegriff"      'Neue Mappe Überschrift in Zeile 1  
Const StartZeile = 2                                    'Neue Mappe Einträge ab Zeile 2  

Const Msg = "Der angegebene Ordner existiert nicht!"  

Sub GetExternData()
    Dim Wkb0 As Workbook, WkbX As Workbook, Wks0 As Worksheet, Wks As Worksheet
    Dim Fso As Object, File As Object, Found As Range, Search As String, NextLine As Long   
 
    Set Fso = CreateObject("Scripting.FileSystemObject")  
    
    If Fso.FolderExists(SuchPfad) = False Then MsgBox Msg, vbExclamation, "Fehler":  Exit Sub  
   
    Search = InputBox("Bitte Suchbegriff eingeben:", "Suchen")  
    
    If Search = "" Then Exit Sub  
    
    Application.ScreenUpdating = False
    
    Workbooks.Add:  Set Wkb0 = ActiveWorkbook:  Set Wks0 = Wkb0.Sheets(1)
    
    With Wks0.Range("A1:C1")  
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
        .Value = Split(TitelZeile, ",")  
    End With
    
    NextLine = StartZeile
    
    For Each File In Fso.GetFolder(SuchPfad).Files
        If File.Name Like SuchName And Not File.Path Like NeueMappe & ".xls*" Then  
            Set WkbX = GetObject(File.Path)
            
            For Each Wks In WkbX.Worksheets
                If Not Wks.Columns(SuchSpalte).Find(Search, LookIn:=xlValues, LookAt:=xlPart) Is Nothing Then
                    With Wks0.Rows(NextLine)
                        .Columns("A") = File.Name  
                        .Columns("B") = Wks.Name  
                        .Columns("C") = Search  
                         NextLine = NextLine + 1
                    End With
                End If
            Next
            
            WkbX.Close False
        End If
    Next
    
    Wks0.Columns("A:C").AutoFit  
    
    With Wkb0
        .Application.DisplayAlerts = False
        .SaveAs NeueMappe, xlNormal
        .Application.DisplayAlerts = True
        .Close False
    End With
    
    Application.ScreenUpdating = True
End Sub

Option Explicit
Option Compare Text

Const SuchPfad = "E:\Threads\137848\Test"               'Such-Ordnerpfad  
Const SuchName = "*.xls*"                               'Such-Dateien  

Const SuchSpalte = "A"                                  'Such-Spalte  

Const TitelZeile = "Dateiname,Produkt,Suchbegriff"      'Neue Mappe Überschrift in Zeile 1  
Const StartZeile = 2                                    'Neue Mappe Einträge ab Zeile 2  

Const Msg = "Der angegebene Ordner existiert nicht!"  

Sub GetExternData()
    Dim Wkb As Workbook, Wks As Worksheet, WksHome As Worksheet
    Dim Fso As Object, File As Object, Found As Range, Search As String, NextLine As Long
    
    Set Fso = CreateObject("Scripting.FileSystemObject")  
    
    If Fso.FolderExists(SuchPfad) = False Then MsgBox Msg, vbExclamation, "Fehler":  Exit Sub  
   
    Search = InputBox("Bitte Suchbegriff eingeben:", "Suchen...")  
    
    If Search = "" Then Exit Sub  
    
    Application.ScreenUpdating = False
    
    Set WksHome = ThisWorkbook.Sheets(1)
    
    WksHome.Cells.ClearContents
    
    With WksHome.Range("A1:C1")  
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
        .Value = Split(TitelZeile, ",")  
    End With
    
    NextLine = StartZeile
    
    For Each File In Fso.GetFolder(SuchPfad).Files
        If File.Name Like SuchName And Not File.Name Like ThisWorkbook.Name Then
            Set Wkb = Workbooks.Open(File.Path)
            
            For Each Wks In Wkb.Worksheets
                If Not Wks.Columns(SuchSpalte).Find(Search, LookIn:=xlValues, LookAt:=xlPart) Is Nothing Then
                    With WksHome.Rows(NextLine)
                        .Columns("A") = File.Name  
                        .Columns("B") = Wks.Name  
                        .Columns("C") = Search  
                         NextLine = NextLine + 1
                    End With
                End If
            Next
            
            Wkb.Close False
        End If
    Next
    
    WksHome.Columns("A:C").AutoFit  
    
    Application.ScreenUpdating = True
End Sub

            Set Wkb = Workbooks.Open(File.Path)

MsgBox "Was gefunden!"