Sub sammeln()
Dim fd, Pfad, Dateiname, lr
Dim Suchstring As String
Dim Bitch As Range
Dim C As Variant
Dim wkb As Workbook
Dim lNextrow As Long
Dim Ra As Range
Set Ra = Range("A1:A300")
Suchstring = "How you can find us"
Set wkb = ActiveWorkbook
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)
Set Bitch = Cells.Find(What:="How you can find us", After:=ActiveCell, LookIn:= _
xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:= _
xlNext, MatchCase:=False, SearchFormat:=False)
Bitch.Select
Selection.Copy
lNextrow = wkb.Worksheets(1).Cells(Rows.Count, "A").End(xlUp).Row + 1
Windows("Book1.xlsm").Activate
wkb.Worksheets(1).Cells(lNextrow, 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
.Close False
End With
Dateiname = Dir()
Loop
End If
End Sub
Ok
ich kann ENDLICH dinge von einem ins nächste kopieren
nun muss ich nur noch offset verstehen
DANKE -.-
|