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.
Hier noch das bisherige Marko:
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
Vielen Dank schon mal im Voraus!
Grüße
pBrue
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.
Hier noch das bisherige Marko:
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
Vielen Dank schon mal im Voraus!
Grüße
pBrue