Danke schon mal im voraus !!!
Torsten
Sub StartVergleich()
VergleichenUndKopieren Sheets("Tabelle1"), 1, 4
End Sub
Sub VergleichenUndKopieren(wks As Worksheet, iCol1 As Integer, iCol2 As Integer)
Dim lngK As Long, rngKopie As Range, wksKopie As Worksheet
Set rngKopie = wks.Rows(1) 'Überschriftenzeile
With wks
For lngK = 1 To .Cells(Rows.Count, iCol1).End(xlUp).Row
If LCase(.Cells(lngK, iCol1)) LCase(.Cells(lngK, iCol2)) Then
Set rngKopie = Union(rngKopie, .Rows(lngK))
End If
Next lngK
End With
If rngKopie.Areas.Count > 1 Then
Set wksKopie = Worksheets.Add(after:=wks)
wksKopie.Name = wks.Name & "_Kopie"
rngKopie.Copy wksKopie.Cells(1, 1)
End If
End Sub
Gruß
Rudi
Eine Kuh macht Muh, viele Kühe machen Mühe