|
Hallo zusammen,
ich habe folgendes Problem:
fast 2000 excel dateien mit einigen daten die zusammengefügt werden sollen.
Ich habe schon einen code gefunden der mir alles öffnet und kopiert, jedoch schaff ich es nicht einmal eine einfach suchen und kopieren funktion zu schreiben.
Es müssten mehrere stellen kopiert in jedem der excel files kopiert werden
Das suchwort ist jedoch nur eine überschrift und eine bzw mehrere zeilen drunter wäre das was eigentlich kopiert werden soll
Folgender Code öffnet die Dateien wenigstens
Sub sammeln()
Dim fd, Pfad, Dateiname, lr
Const Suchstring As String = "How you can find us"
Dim Zelle As Range
Dim loLetzteA As Long
Dim loLetzteB As Long
Dim C As Variant
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
If fd.Show() = True Then
Pfad = fd.SelectedItems(1) & "\"
Dateiname = Dir(Pfad & "*.xls")
Do While Dateiname <> ""
With Workbooks.Open(Pfad & Dateiname, , True)
For sh = 1 To .Worksheets.Count
loLetzteA = IIf(IsEmpty(Cells(Rows.Count, 1)), Cells(Rows.Count, 1).End(xlUp).Row, Rows.Count)
For Each Zelle In Range(Cells(1, 1), Cells(loLetzteA, 2))
If InStr(Zelle, Suchstring) > 0 Then
loLetzteB = IIf(IsEmpty(Cells(Rows.Count, 2)), Cells(Rows.Count, 2).End(xlUp).Row, Rows.Count)
Zelle.Copy
Workbooks(GetThisWB).Activate
Cells(loLetzteB + 1, 1).PasteSpecial xlPasteValues
End If
Next Zelle
Next
.Close False
End With
Dateiname = Dir()
Loop
End If
End Sub
Leider kopiert er nichts.
Ich bitte um Hilfe ! |