Option
Explicit
Sub
Test()
Dim
wksSrc
As
Excel.Worksheet
Dim
wksDst
As
Excel.Worksheet
Dim
rngFilter
As
Excel.Range
Dim
rngData
As
Excel.Range
Set
wksSrc = ThisWorkbook.Worksheets(
"SITE FM"
)
Set
wksDst = ThisWorkbook.Worksheets(
"Zieltabelle"
)
With
wksSrc
Set
rngFilter = .Range(
"AA1"
, .Cells(.Rows.Count,
"AA"
).
End
(xlUp))
Set
rngData = .Range(
"A1:Z"
& rngFilter(rngFilter.Cells.Count).Row)
End
With
With
wksDst
Dim
rngDst
As
Excel.Range
Set
rngDst = .Range(
"A1"
)
Set
rngDst = rngDst.Resize(1, rngData.Columns.Count)
Dim
colResults
As
VBA.Collection
Dim
rngResult
As
Excel.Range
Set
colResults =
New
VBA.Collection
Set
rngResult = rngFilter.Find(What:=
"x"
, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, MatchCase:=
False
, MatchByte:=
False
)
If
rngResult
Is
Nothing
Then
Call
MsgBox(
"Es sind keine Datensätze markiert."
, vbExclamation)
Exit
Sub
Else
On
Error
Resume
Next
Do
Call
colResults.Add(rngResult, rngResult.Address)
If
Err.Number <> 0
Then
Exit
Do
Set
rngResult = rngFilter.FindNext(rngResult)
Loop
On
Error
GoTo
0
End
If
For
Each
rngResult
In
colResults
rngDst.Value = rngData.Rows(1).Offset(rngResult.Row - rngData.Row).Value
Set
rngDst = rngDst.Offset(1)
Next
End
With
Call
MsgBox(
"Datensätze kopiert: "
& colResults.Count, vbInformation,
"Fertig"
)
End
Sub