|
Versuch das mal so:
Sub WiederholungenFinden()
Dim LZ1 As Long, LZ2 As Long, LZ3 As Long, R1 As Long, R2 As Long, s1 As String, s2 As String, I&
Dim Arr1, Arr2, Ausgabe, rng2 As Range, NeueNummer As Boolean
Application.ScreenUpdating = False
With Sheets("Namensliste 1")
LZ1 = .Range("B65536").End(xlUp).Row
Arr1 = .Range("B1:B" & LZ1)
End With
With Sheets("Namensliste 2")
LZ2 = .Range("B65536").End(xlUp).Row
Set rng2 = .Range("B1:B" & LZ2)
Arr2 = rng2
End With
ReDim Ausgabe(Application.WorksheetFunction.Max(LZ2, LZ1), 0)
For R2 = 2 To LZ2
NeueNummer = True
s1 = Arr2(R2, 1)
For R1 = 2 To LZ1
If s1 = Arr1(R1, 1) Then
NeueNummer = False
Exit For
End If
Next
If NeueNummer Then
Ausgabe(I, 0) = s1
rng2(R2, 1).Interior.ColorIndex = 4
I = I + 1
End If
Next
'ausgabe
With Sheets("Auswertung")
LZ3 = .Range("B65536").End(xlUp).Row
With .Range(.Cells(LZ3 + 1, 2), .Cells(LZ3 + I + 1, 2))
.Value = Ausgabe
End With
End With
Application.ScreenUpdating = True
End Sub
Sollte bei 10k * 10k in < 30 Sek durchlaufen... und funktionieren. Solltest bei rechenintensiven Sachen mit Arrays und nicht mit Range Objekten arbeiten...
|