mögliche Dubletten identifizieren

Hallo zusammen,
first time here, so be nice :-)
Ich habe das Problem, dass ich sehr viele Fälle (30.000+) habe, die auf Dubletten durchsucht werden müssen. Leider ist die Datenqualität mitunter schlecht, bzw. die Eingabe sehr unterschiedlich, da die Fälle aus unterschiedlichen Datenquellen stammen. Daher ist ein Kontextabgleich im Einzelfall nötig.
Meine Daten sind wie in der Beispieldatei strukturiert (ein paar mehr Variablen sind es noch, aber die für den Abgleich wichtigsten sind angeführt). Meine Idee ist, dass Excel mögliche Duplikate identifiziert, indem es bspw. nach der Kombination Erster Vorname+Nachname+Geburtsjahr sucht und mir dann in einer Msg-Box vorschlägt, dass "Michael Schröder 1900 SPD" und "Michael Schröder 1900 SPD" eine Dopplung sein könnten. Wenn ich dann "ja" anklicke, erhalten beide Fälle dieselbe Lfd-Nr. Bei "nein" bleiben die Lfd-Nummern separiert.
Könnt ihr mir da helfen?
https://www.herber.de/bbs/user/148965.xlsx

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Sub Doppelte() Dim LR As Integer, i As Integer, rng As Range Dim JaNein, Lfd1 As Integer With ThisWorkbook.Sheets("Tabelle1") Set rng = .Range("A:F") 'Sortiern .Sort.SortFields.Clear .Sort.SortFields.Add2 Key:=.Columns(2), SortOn:=xlSortOnValues, _ Order:=xlAscending, DataOption:=xlSortNormal .Sort.SortFields.Add2 Key:=.Columns(3), SortOn:=xlSortOnValues, _ Order:=xlAscending, DataOption:=xlSortNormal .Sort.SortFields.Add2 Key:=.Columns(5), SortOn:=xlSortOnValues, _ Order:=xlAscending, DataOption:=xlSortNormal .Sort.SortFields.Add2 Key:=.Columns(1), SortOn:=xlSortOnValues, _ Order:=xlAscending, DataOption:=xlSortNormal .Sort.SetRange rng .Sort.Header = xlYes .Sort.MatchCase = False .Sort.Orientation = xlTopToBottom .Sort.SortMethod = xlPinYin .Sort.Apply LR = .Cells(.Rows.Count, "A").End(xlUp).Row 'letzte Zeile der Spalte For i = 3 To LR If .Cells(i, 2) = .Cells(i - 1, 2) And _ .Cells(i, 3) = .Cells(i - 1, 3) And _ .Cells(i, 5) = .Cells(i - 1, 5) Then Lfd1 = WorksheetFunction.Min(.Cells(i - 1, 1).Resize(2)) JaNein = MsgBox(.Cells(i, 2) & ", " & .Cells(i, 3) & ", " & .Cells(i, 5) & _ vbLf & vbLf & "Gleiche Laufnummer vergeben?", vbQuestion + vbYesNo, "Dopplung:") If JaNein = vbYes Then .Cells(i, 1) = Lfd1 End If End If Next i End With End Sub

Public Function bd_levenshtein(A, b) Dim i, j, cost, D, min1, min2, min3 ' Avoid calculations where there there are empty words If Len(A) = 0 Then bd_levenshtein = Len(b): Exit Function If Len(b) = 0 Then bd_levenshtein = Len(A): Exit Function ' Array initialization ReDim D(Len(A), Len(b)) For i = 0 To Len(A): D(i, 0) = i: Next For j = 0 To Len(b): D(0, j) = j: Next ' Actual calculation For i = 1 To Len(A) For j = 1 To Len(b) If Mid(A, i, 1) = Mid(b, j, 1) Then cost = 0 Else cost = 1 ' Since min() function is not a part of VBScript, we'll "emulate" it below min1 = (D(i - 1, j) + 1) min2 = (D(i, j - 1) + 1) min3 = (D(i - 1, j - 1) + cost) If min1

Hallo Nepumuk,
danke, das funktioniert schon super. Tausend Dank! Ich habe das mal mit einem Ausschnitt der Daten getestet und bin darüber gestolpert, dass einige Lfd-Nummern offensichtlich falsch zugeordnet werden: Zum Beispiel werden Manfred und Thomas Schäfer mit unterschiedlichen Geburtsjahren und unterschiedlichen Parteien zusammengesteckt (siehe hier: https://www.herber.de/bbs/user/149002.xlsm). Da ich bei dem Code leider wie ein Schwein ins Uhrwerk gucke, kann ich leider nicht identifizieren, wo das Problem liegt. Falls du da nochmal schauen könntest, wäre ich dir sehr dankbar!
Außerdem hatte ich versucht, eine Msgbox einzubauen, die mich jedes Mal vorher fragt, ob die tatsächlich zusammengehören. Leider bin ich auch daran gescheitert (sehr bescheidene VBA-Kenntnisse):
Option Explicit


Public Sub Compare()
Dim avntValues As Variant, avntKeys As Variant, avntItems As Variant
Dim ialngIndex1 As Long, ialngIndex2 As Long
Dim strTemp As String
Dim objDictionary As Object
With Tabelle1
avntValues = .Range(.Cells(2, 1), .Cells(.Rows.Count, 6).End(xlUp)).Value2
End With
Set objDictionary = CreateObject(Class:="Scripting.Dictionary")
With objDictionary
For ialngIndex1 = LBound(avntValues, 1) To UBound(avntValues, 1)
strTemp = Transform(avntValues(ialngIndex1, 2) & avntValues(ialngIndex1, 4) & avntValues(ialngIndex1, 6))
If Not .Exists(strTemp) Then
Call .Add(Key:=strTemp, Item:=avntValues(ialngIndex1, 1))
Else
Tabelle1.Cells(ialngIndex1 + 1, 1).Value = .Item(Key:=strTemp)
End If
Next
avntKeys = objDictionary.Keys
avntItems = objDictionary.Items
For ialngIndex1 = LBound(avntKeys) To UBound(avntKeys) - 1
For ialngIndex2 = ialngIndex1 + 1 To UBound(avntKeys)
If Levenshtein_Distance(avntKeys(ialngIndex1), avntKeys(ialngIndex2))

Tausend Dank!

Public Sub Compare() Dim avntValues As Variant Dim ialngIndex As Long Dim strTemp As String Dim objDictionary As Object With Tabelle1 avntValues = .Range(.Cells(2, 1), .Cells(.Rows.Count, 6).End(xlUp)).Value2 End With Set objDictionary = CreateObject(Class:="Scripting.Dictionary") With objDictionary For ialngIndex = LBound(avntValues, 1) To UBound(avntValues, 1) strTemp = Transform(avntValues(ialngIndex, 2) & avntValues(ialngIndex, 4) & avntValues(ialngIndex, 6)) & avntValues(ialngIndex, 5) If Not .Exists(strTemp) Then Call .Add(Key:=strTemp, Item:=avntValues(ialngIndex, 1)) Else Tabelle1.Cells(ialngIndex + 1, 1).Value = .Item(Key:=strTemp) End If Next End With Set objDictionary = Nothing End Sub

Beliebteste Forumthreads (12 Monate)

mögliche Dubletten identifizieren

9 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread