Option Explicit
Sub ChkIt()
'**************************************************************************
'ACHTUNG - Microsoft Scripting Runtime in VBA Projekt Verweise EINBINDEN!!!
'**************************************************************************
Dim dict As Dictionary
'**************************************************************************
'ACHTUNG - sonst knallts !!!
'**************************************************************************
'
'ab Zeile 3 mit Überschrift !!!
'
Dim oWs As Excel.Worksheet
Dim rngChk As Range, rngNew As Range
Dim arrChk As Variant, arrNew As Variant
Dim x As Long, y As Long
Dim sKey As String
'
Set dict = New Dictionary
dict.CompareMode = TextCompare
Set oWs = ThisWorkbook.ActiveSheet
With oWs
Set rngChk = .Range("A3").CurrentRegion
'Überschrift
Set rngChk = rngChk.Offset(1, 0).Resize(rngChk.Rows.Count - 1, rngChk.Columns.Count)
'Spalte B - H
Set rngChk = Range(rngChk.Columns(2), rngChk.Columns(8))
'letze Zeile = Prüfzeile
Set rngNew = rngChk.Rows(rngChk.Rows.Count)
'letze Zeile weg
Set rngChk = rngChk.Resize(rngChk.Rows.Count - 1, rngChk.Columns.Count)
'Datenfelder
arrChk = rngChk: arrNew = rngNew
'letze Zeile
sKey = ""
For y = LBound(arrNew, 2) To UBound(arrNew, 2)
sKey = sKey & arrNew(1, y)
Next y
'ins dict
dict.Add Key:=sKey, Item:=0
'vergleichen
For x = UBound(arrChk, 1) To LBound(arrChk, 1) Step -1
sKey = ""
'aktuelle Zeile
For y = LBound(arrNew, 2) To UBound(arrNew, 2)
sKey = sKey & arrChk(x, y)
Next y
' = gespeicherte Zeile ?
If dict.Exists(sKey) Then _
Call MsgBox("in Zeile " & Format(x + 3, "#0"), vbExclamation, "Doppelter Eintrag")
Next x
End With
Set oWs = Nothing
Set dict = Nothing
End Sub
|