Option Explicit
Const searchMarker As String = "x"
Const rngMarker As String = "A:A"
Private Type StatusWorkbook
Workbook As Workbook
opened As Boolean
End Type
Sub Transfer()
Dim dlg As FileDialog
Dim SelectItem As Variant
Dim statusWbk As StatusWorkbook
Dim wbk As Workbook
Dim wsh As Worksheet
Dim rng As Range, lngRow As Long
Set dlg = Application.FileDialog(msoFileDialogOpen)
With dlg
.AllowMultiSelect = True
.InitialFileName = ThisWorkbook.Path & "\"
.Title = "Wähle alle zu durchsuchende Dateien aus der Liste"
.ButtonName = "Einlesen"
.Show
For Each SelectItem In .SelectedItems
statusWbk = GetWorkbook(SelectItem)
Set wbk = statusWbk.Workbook
If Not wbk Is Nothing Then
For Each wsh In wbk.Worksheets
With wsh.Range(rngMarker)
lngRow = 0
Set rng = .Find(What:=searchMarker, LookIn:=xlValues, lookat:=xlWhole, MatchCase:=True, SearchDirection:=xlNext)
Do Until rng Is Nothing
If lngRow > rng.Row Then
Exit Do
End If
lngRow = rng.Row
copyRowInNewWorkbook rng
Set rng = .FindNext(after:=rng)
Loop
End With
Next
If statusWbk.opened Then
If Not Application.CutCopyMode = False Then
Application.CutCopyMode = False
End If
wbk.Close SaveChanges:=False
End If
End If
Next
End With
End Sub
Function GetWorkbook(ByVal fullName As String) As StatusWorkbook
Dim wbk As Workbook
Dim bExists As Boolean
For Each wbk In Application.Workbooks
If wbk.fullName = fullName Then
bExists = True
Exit For
End If
Next
If Not bExists Then
Set wbk = Application.Workbooks.Open(fullName)
End If
Set GetWorkbook.Workbook = wbk
GetWorkbook.opened = Not bExists
End Function
Sub copyRowInNewWorkbook(rng As Range)
Static wbk As Workbook
Static lngRow As Long
If wbk Is Nothing Then
Set wbk = Application.Workbooks.Add
End If
rng.EntireRow.Copy
lngRow = lngRow + 1
wbk.Activate
With wbk.Worksheets(1)
.Activate
With .Rows(lngRow).Cells(1, 1)
.Select
ActiveSheet.Paste
End With
End With
End Sub