Excel Dateien durchsuchen und Werte in neue Excel Datei auslesen

Option Explicit

Sub GetData()

Dim oMe As Object
Set oMe = Workbooks("Alle.xls").Worksheets("Tabelle1") 'ZielDatei/-Tabelle (also die gerade geöffnete) ;-)  
Const sDateiPfad As String = "D:\Test\" 'Pfad für zu durchsuchende Excel-Dateien; mit Backslash am Ende  
Const iSbAnzahl = 3 'Nach 3 Begriffen suchen  
Dim sSuchbegriff(iSbAnzahl) As String
sSuchbegriff(1) = "Name"  
sSuchbegriff(2) = "Vorname"  
sSuchbegriff(3) = "Strasse"  

Dim i As Integer
Dim sWbName As String
Dim rFound As Range
Dim vWert As Variant
Dim iZeile As Integer

iZeile = 2
Dim oFS As Object, oDatei As Object
Set oFS = CreateObject("Scripting.FileSystemObject")  
For Each oDatei In oFS.GetFolder(sDateiPfad).Files
    sWbName = oDatei.Name
    Workbooks.Open (sDateiPfad & sWbName)
    For i = 1 To iSbAnzahl
        Set rFound = Workbooks(sWbName).Worksheets(1).Range("a1:a100").Find(sSuchbegriff(i), LookIn:=xlValues)  
        If Not rFound Is Nothing Then
            vWert = Cells(rFound.Row, rFound.Column + 1).Value
            oMe.Cells(iZeile, i).Value = vWert
        End If
    Next
    Workbooks(sWbName).Saved = True
    Workbooks(sWbName).Close
    iZeile = iZeile + 1
Next
End Sub

Option Explicit

Sub GetData()

Dim oMe As Object, sSuchbegriff(), sBereich As String, iZeile As Integer, sKennz As String
Dim iSbMax As Integer, iLK As Integer, i As Integer, sWbName As String, rFound As Range, vWert As Variant
Dim oFS As Object, oDatei As Object, wsTabelle As Worksheet, bEintrag As Boolean

Set oMe = ThisWorkbook.Worksheets("Tabelle1") 'Zieltabelle (in der gerade geöffneten Datei)  
iZeile = 2 'ab dieser Zeile Ergebnisse in die Zieltabelle eintragen  
Const sDateiPfad As String = "D:\Test\" 'Pfad für zu durchsuchende Excel-Dateien; mit Backslash am Ende  
sKennz = "Test" 'Nur Tabellen, deren Name mit dem Kennzeichen beginnt, verarbeiten  
sSuchbegriff = Array("Name", "Vorname", "Strasse") 'Liste der Suchbegriffe  
sBereich = "A1:A100"  

iSbMax = UBound(sSuchbegriff) 'Höchster Index der Suchbegriffmatrix  
iLK = Len(sKennz) 'Länge des Tabellennamen-Kennzeichens  

Set oFS = CreateObject("Scripting.FileSystemObject")  
For Each oDatei In oFS.GetFolder(sDateiPfad).Files
    sWbName = oDatei.Name
    Workbooks.Open (oDatei.Path)
    For Each wsTabelle In Workbooks(sWbName).Worksheets()
        If StrComp(Left(wsTabelle.Name, iLK), sKennz, vbTextCompare) = 0 Then
            bEintrag = False
            For i = 0 To iSbMax
                Set rFound = wsTabelle.Range(sBereich).Find(sSuchbegriff(i), LookIn:=xlValues)
                If Not rFound Is Nothing Then
                    vWert = wsTabelle.Cells(rFound.Row, rFound.Column + 1).Value
                    oMe.Cells(iZeile, i + 1).Value = vWert
                    bEintrag = True
                End If
            Next
            If bEintrag Then iZeile = iZeile + 1 'mindestens ein Eintrag erfolgt, daher neue Zeile  
        End If
    Next
    Workbooks(sWbName).Saved = True
    Workbooks(sWbName).Close
Next
End Sub

Option Explicit

Sub GetData()

Dim oMe As Object, sUeber() As String, sVK()
Dim iZSpalte As Integer, iZZeile As Integer, iZAbZeile As Integer, iZAbSpalte As Integer, iZSpAnz As Integer
Dim iQZeile As Integer, iQSpalte As Integer, iQAbZeile As Integer, iQAbSpalte As Integer, iQSpAnz As Integer
Dim sWbName As String, sName As String, sV As Variant, iLeist As Integer


'######## ab hier anpassen ########  
Set oMe = ThisWorkbook.Worksheets("Tabelle1") 'Zieltabelle (in der gerade geöffneten Datei)  
Const sDateiPfad As String = "D:\Test\" 'Pfad für zu durchsuchende Excel-Dateien; mit Backslash am Ende  

sUeber = Split("Dateiname Name Vertriebskanal Leistung") 'Spaltenüberschriften  
iZAbSpalte = 1 'ab dieser Spalte Ergebnisse in die Zieltabelle eintragen  
iZAbZeile = 1 'ab dieser Zeile Ergebnisse in die Zieltabelle eintragen (Spaltenüberschriften; Leerzeichen als Trennzeichen)  

iQAbSpalte = 1 'ab dieser Spalte Daten in Quelltabelle enthalten  
iQAbZeile = 1 'ab dieser Zeile Daten in Quelltabelle enthalten  
'######## bis hier anpassen ########  


iZSpAnz = UBound(sUeber)
With oMe
    .Cells.Clear 'gesamte Zieltabelle löschen  
    .Range(.Cells(iZAbZeile, iZAbSpalte), .Cells(iZAbZeile, iZAbSpalte + iZSpAnz)).Value = sUeber 'Überschriften eintragen  
End With
iZZeile = iZAbZeile + 1

Dim oFS As Object, oDatei As Object
Set oFS = CreateObject("Scripting.FileSystemObject")  
For Each oDatei In oFS.GetFolder(sDateiPfad).Files
    sWbName = oDatei.Name
    Workbooks.Open (sDateiPfad & sWbName)
    With Workbooks(sWbName).Worksheets(1)
        iQSpalte = iQAbSpalte + 1 'Vertriebskanäle ab dieser Spalte  
        iQZeile = iQAbZeile 'Überschriften ab dieser Zeile  
        Do While .Cells(iQZeile, iQSpalte).Value <> ""  
            iQSpalte = iQSpalte + 1
        Loop
        iQSpAnz = iQSpalte - iQAbSpalte - 1
                
        sVK = .Range(.Cells(iQAbZeile, iQAbSpalte + 1), .Cells(iQAbZeile, iQAbSpalte + iQSpAnz)).Value
        
        iQZeile = iQZeile + 1
        iQSpalte = iQAbSpalte
        
        Do While .Cells(iQZeile, iQAbSpalte).Value <> ""  
            iQSpalte = iQAbSpalte
            sName = .Cells(iQZeile, iQSpalte).Value
            For Each sV In sVK
                iQSpalte = iQSpalte + 1
                iLeist = .Cells(iQZeile, iQSpalte).Value
                With oMe
                    'Eintragung in Zieltabelle; Reihenfolge siehe Überschriften (sUeber)  
                    .Cells(iZZeile, iZAbSpalte).Value = sWbName
                    .Cells(iZZeile, iZAbSpalte + 1).Value = sName
                    .Cells(iZZeile, iZAbSpalte + 2).Value = sV
                    .Cells(iZZeile, iZAbSpalte + 3).Value = iLeist
                    iZZeile = iZZeile + 1
                End With
            Next
            iQZeile = iQZeile + 1
        Loop
    End With
    
    Workbooks(sWbName).Saved = True
    Workbooks(sWbName).Close
    
Next

'Sortierung: zunächst (Key1) nach Datei, dann (Key2)nach Name  
With oMe
.Cells(iZAbZeile, iZAbSpalte).Sort _
    Key1:=.Cells(iZAbZeile, iZAbSpalte), Order1:=xlAscending, _
    Key2:=.Cells(iZAbZeile, iZAbSpalte + 1), Order2:=xlAscending, _
    Header:=xlYes, OrderCustom:=1, Orientation:=xlTopToBottom
End With
End Sub

Sub GetData()

Dim oMe As Object, sBereich As String, iZeile As Integer, iSpalte As Integer, sKennz As String
Dim i As Integer, sWbName As String, rFound As Range
Dim vName As Variant, vVorname As Variant, vBU As Variant, vAbteilung As Variant, vMPK1 As Variant, vMPK2 As Variant, vMPK3 As Variant
Dim oFS As Object, oDatei As Object, wsTabelle As Worksheet, bEintrag As Boolean

Set oMe = ThisWorkbook.Worksheets("Tabelle1") 'Zieltabelle (in der gerade geöffneten Datei)  

iZeile = 4 'ab dieser Zeile Ergebnisse in die Zieltabelle eintragen  
iSpalte = 1

Const sDateiPfad As String = "H:\Eigene Dateien\Dateienauslesen\" 'Pfad für zu durchsuchende Excel-Dateien; mit Backslash am Ende  
Const iSbAnzahl = 7 'Nach x Begriffen suchen  
Dim sSuchbegriff(iSbAnzahl) As String
sSuchbegriff(1) = "Name:"  
sSuchbegriff(2) = "Vorname:"  
sSuchbegriff(3) = "BU:"  
sSuchbegriff(4) = "Abteilung:"  
sSuchbegriff(5) = "Auszahlung Monatspraemie 1"  
sSuchbegriff(6) = "Auszahlung Monatspraemie 2"  
sSuchbegriff(7) = "Auszahlung Monatspraemie 3"  
sBereich = "A1:Z200"  

Set oFS = CreateObject("Scripting.FileSystemObject")  
For Each oDatei In oFS.GetFolder(sDateiPfad).Files
    sWbName = oDatei.Name
    Workbooks.Open (oDatei.Path), Password:="pw", WriteResPassword:="pw"  
    For Each wsTabelle In Workbooks(sWbName).Worksheets()
            For i = 0 To iSbAnzahl
                Set rFound = wsTabelle.Range(sBereich).Find(sSuchbegriff(i), LookIn:=xlValues)
                If Not rFound Is Nothing Then
                    vWert = wsTabelle.Cells(rFound.Row, rFound.Column + 1).Value
                    vVorname = wsTabelle.Cells(rFound.Row, rFound.Column + 1).Value
                    vBU = wsTabelle.Cells(rFound.Row, rFound.Column + 1).Value
                    vAbteilung = wsTabelle.Cells(rFound.Row, rFound.Column + 1).Value
                    vMPK1 = wsTabelle.Cells(rFound.Row + 1, rFound.Column).Value
                    vMPK2 = wsTabelle.Cells(rFound.Row + 1, rFound.Column).Value
                    vMPK3 = wsTabelle.Cells(rFound.Row + 1, rFound.Column).Value
                    With oMe
                    .Cells(iZeile, i + 1).Value = vName
                    .Cells(iZeile, i + 2).Value = vVorname
                    .Cells(iZeile, i + 3).Value = vBU
                    .Cells(iZeile, i + 4).Value = vAbteilung
                    .Cells(iZeile, i + 5).Value = vMPK1
                    .Cells(iZeile, i + 6).Value = vMPK2
                    .Cells(iZeile, i + 7).Value = vMPK3
                    bEintrag = True
                    End With
                End If
            Next
            If bEintrag Then iZeile = iZeile + 1 'mindestens ein Eintrag erfolgt, daher neue Zeile  
    Next
    Workbooks(sWbName).Saved = True
    Workbooks(sWbName).Close
Next
End Sub

Sub GetData()

Set oMe = ThisWorkbook.ActiveSheet 'ZielDatei/-Tabelle (= die aktuelle Tabelle der aktuellen Datei)  
Const sDateiPfad As String = "D:\Test\" 'Pfad für zu durchsuchende Excel-Dateien; mit Backslash am Ende  

sZelle = "H5" 'auszulesende Zelle  
iZeile = 2 'ab Zeile 2 in Zieltabelle eintragen  
iSpalte = 1 'ab Spalte A in Zieltabelle eintragen  

Set oFS = CreateObject("Scripting.FileSystemObject")  
For Each oDatei In oFS.GetFolder(sDateiPfad).Files
    sWbName = oDatei.Name
    If Left(LCase(oFS.GetExtensionName(sWbName)), 3) = "xls" Then  
        Workbooks.Open (sDateiPfad & sWbName)
        oMe.Cells(iZeile, iSpalte).Value = Range(sZelle).Value
        oMe.Hyperlinks.Add Anchor:=oMe.Cells(iZeile, iSpalte + 1), Address:=sDateiPfad & sWbName, TextToDisplay:=sWbName
        Workbooks(sWbName).Saved = True
        Workbooks(sWbName).Close
        iZeile = iZeile + 1
    End If
Next
End Sub

        oMe.Cells(iZeile, iSpalte).Value = Workbooks(sWbName).ActiveSheet.Range(sZelle).Value

Sub GetData()

Set oMe = ThisWorkbook.ActiveSheet 'ZielDatei/-Tabelle (= die aktuelle Tabelle der aktuellen Datei)  
Const sDateiPfad As String = "D:\Test\" 'Pfad für zu durchsuchende Excel-Dateien; mit Backslash am Ende  

sZelle1 = "H5" 'auszulesende Zelle  
sZelle2 = "D5" 'weitere auszulesende Zelle  
iZeile = 2 'ab Zeile 2 in Zieltabelle eintragen  
iSpalte = 1 'ab Spalte A in Zieltabelle eintragen  

Set oFS = CreateObject("Scripting.FileSystemObject")  
For Each oDatei In oFS.GetFolder(sDateiPfad).Files
    sWbName = oDatei.Name
    If Left(LCase(oFS.GetExtensionName(sWbName)), 3) = "xls" Then  
        Workbooks.Open (sDateiPfad & sWbName)
        oMe.Cells(iZeile, iSpalte).Value = Workbooks(sWbName).ActiveSheet.Range(sZelle1).Value
        oMe.Cells(iZeile, iSpalte + 1).Value = Workbooks(sWbName).ActiveSheet.Range(sZelle2).Value
        oMe.Hyperlinks.Add Anchor:=oMe.Cells(iZeile, iSpalte + 2), Address:=sDateiPfad & sWbName, TextToDisplay:=sWbName
        Workbooks(sWbName).Saved = True
        Workbooks(sWbName).Close
        iZeile = iZeile + 1
    End If
Next
End Sub