|
Hallo,
teste mal:
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
Von folgenden Voraussetzungen bin ich ausgegangen:
Blatt Alle: In Zeile 1 sind Überschriften, Daten beginnen in Zeile 2
Blatt Suchmeldungen: Die Suchbegriffe stehen in Spalte A - A1 bis A??
Gruß Werner
|