Hallo,

ich würde gerne aus ca. 600 Excel-Dateien mit einem Makro mit bestimmte Angaben in jeder Excel-Liste herauskopieren und die Daten aus alles Dateien in einer abspeichern.
Ich habe mir bereits ein Makro gebastelt, aber dies funktioniert leider noch nicht so wie es soll.

Also Info zu den Excel-Listen: Das Suchwort steht in jeder Excel-Datei in Zeile 1 in form einer Überschrift (Z. B. "Name", "Ort", ...) und in Zeile zwei steht der dazugehörige Eintrag.
Ich würde mich riesig freuen wenn sich damit jemand auskennt und sich das jemand mal anschauen würde. Vielleicht ist es einfach nur ein ganz simpler Fehler, den ich einfach nur nicht entdecke.

[U][B]Hier noch das bisherige Marko: [/U]

Option Explicit

Private WS As Object

Sub Pfadmakro()
    Dim cDir As String
    Dim sPath As String
    Dim arrSuche As Variant
    Dim i As Long
    Dim lRow As Long
    Dim lcolumn As Long
    Dim WB As Workbook
    Dim TS As Worksheet
    
    sPath = "C:\Zielordner\"
    arrSuche = Array("Vorwahl", "Position", "Rufnummer", "Name")
    cDir = Dir(sPath & "*.xlsx")
   
    Do While cDir <> ""
        Set WB = Workbooks.Open(sPath & cDir) 'öffnet die Datei
        Set WS = WB.Worksheets("Tabelle1")
        Set TS = ThisWorkbook.Worksheets("Tabelle1")
    
         lcolumn = TS.Cells(1, Columns.Count).End(xlToLeft).Columns + 1
         For i = LBound(arrSuche) To UBound(arrSuche)
             TS.Cells(lcolumn, i + 1) = Modul1.Suche(arrSuche(i))
         Next i

        WB.Close savechanges:=False
   
        cDir = Dir 'nächste Datei lesen
    Loop
End Sub
 
Function Suche(ByVal strSuche As String) As String
Dim Zelle As Range

Set Zelle = WS.Range("A:ZZ").Find(What:=strSuche, LookIn:=xlValues, LookAt:=xlWhole)

If Not Zelle Is Nothing Then
    Suche = Zelle.Offset(1, 0).Text
End If
End Function[/B]


Vielen Dank schon mal im Voraus!

Grüße

pBrue