Sub
Makro1()
Dim
varArray1
As
Variant
, varArray2
As
Variant
, loLetzte
As
Long
Dim
i
As
Long
, z
As
Long
, raKopie
As
Range
Application.ScreenUpdating =
False
Application.EnableEvents =
False
Application.Calculation = xlCalculationManual
With
Worksheets(
"Suchmeldungen"
)
loLetzte = .Cells(.Rows.Count,
"A"
).
End
(xlUp).Row
varArray1 = WorksheetFunction.Transpose(.Range(
"A1:A"
& loLetzte))
End
With
With
Worksheets(
"Alle"
)
loLetzte = .Cells(.Rows.Count,
"E"
).
End
(xlUp).Row
varArray2 = WorksheetFunction.Transpose(.Range(
"E2:E"
& loLetzte))
For
i = LBound(varArray1)
To
UBound(varArray1)
For
z = LBound(varArray2)
To
UBound(varArray2)
If
varArray2(z)
Like
"*"
& varArray1(i) &
"*"
Then
If
raKopie
Is
Nothing
Then
Set
raKopie = .Cells(z + 1,
"E"
)
Else
Set
raKopie = Union(raKopie, .Cells(z + 1,
"E"
))
End
If
End
If
Next
z
Next
i
End
With
If
Not
raKopie
Is
Nothing
Then
raKopie.EntireRow.Copy
Worksheets(
"Ausprogrammieren"
).Range(
"A1"
).PasteSpecial Paste:=xlPasteValues
raKopie.EntireRow.Delete
End
If
Set
raKopie =
Nothing
Application.CutCopyMode =
False
Application.EnableEvents =
True
Application.Calculation = xlCalculationAutomatic
End
Sub