Any help would be appreciated, I have a workbook where I need to find fuzzy duplicates, however I am not sure how to code in VBA to get excel to do what I want. I was looking to get it put a percentage and row number of the duplicate in the two columns next the data to indicate a duplicate/ possible duplicate. The attachment contains the outcome I am trying to get.
I have been trying to modify this code to do so, but it wont run, Any help on this would be appreciated
PHP Code:
Option Explicit
Dim mobjDictionary As Object
Sub GetMatches()
Dim iPtr As Integer
Dim lRow As Long, lRowEnd As Long, lItem As Long
Dim saKey() As String, sKey As String
Dim saKeyCombos() As String
Dim sngPercent As Single
Dim vCur As Variant, vData As Variant
Dim WS As Worksheet
Set mobjDictionary = Nothing
Set mobjDictionary = CreateObject("Scripting.Dictionary")
ReDim saKey(1 To 3)
Set WS = Sheets("all_a_brand")
lRowEnd = WS.Cells(Rows.Count, "A").End(xlUp).Row
For lRow = 2 To lRowEnd
vCur = WS.Range("A" & lRow & ":C" & lRow).Value
For iPtr = 1 To 3
saKey(iPtr) = NormaliseKey(CStr(vCur(1, iPtr)))
Next iPtr
saKeyCombos = GetKeyCombos(saKey)
For iPtr = 1 To UBound(saKeyCombos)
On Error Resume Next
mobjDictionary.Add Key:=saKeyCombos(iPtr), Item:=lRow
On Error GoTo 0
Next iPtr
For iPtr = 1 To UBound(saKey)
sKey = Left$("|||", iPtr - 1) & saKey(iPtr) & Left$("|||", 3 - iPtr)
On Error Resume Next
mobjDictionary.Add Key:=sKey, Item:=lRow
On Error GoTo 0
Next iPtr
Next lRow
ReDim vData(1 To 1, 1 To 2)
For lRow = 2 To lRowEnd
vCur = WS.Range("A" & lRow & ":C" & lRow).Value
For iPtr = 1 To 3
saKey(iPtr) = NormaliseKey(CStr(vCur(1, iPtr)))
Next iPtr
saKeyCombos = GetKeyCombos(saKey)
sngPercent = 0
lItem = 0
lItem = mobjDictionary.Item(saKeyCombos(1))
If lItem <> lRow Then
sngPercent = 1
Else
For iPtr = 2 To UBound(saKeyCombos)
lItem = mobjDictionary.Item(saKeyCombos(iPtr))
If lItem <> lRow Then
sngPercent = 0.66
Exit For
End If
Next iPtr
If sngPercent = 0 Then
For iPtr = 1 To UBound(saKey)
sKey = Left$("|||", iPtr - 1) & saKey(iPtr) & Left$("|||", 3 - iPtr)
lItem = mobjDictionary.Item(sKey)
If lItem <> lRow Then
sngPercent = 0.33
Exit For
End If
Next iPtr
End If
End If
If sngPercent <> 0 Then
vData(1, 1) = sngPercent
vData(1, 2) = lItem
WS.Range("D" & lRow, "E" & lRow).Value = vData
End If
Next lRow
mobjDictionary.RemoveAll
Set mobjDictionary = Nothing
End Sub
Private Function NormaliseKey(ByVal String1 As String) As String
Dim iPtr As Integer
Dim sChar As String
NormaliseKey = ""
For iPtr = 1 To Len(String1)
sChar = UCase$(Mid$(String1, iPtr, 1))
If sChar <> LCase$(sChar) _
Or IsNumeric(sChar) Then NormaliseKey = NormaliseKey & sChar
Next iPtr
End Function
Private Function GetKeyCombos(ByRef Keys() As String) As String()
Dim saCombos() As String
ReDim saCombos(1 To 4)
saCombos(1) = Keys(1) & "|" & Keys(2) & "|" & Keys(3)
saCombos(2) = Keys(1) & "||" & Keys(3)
saCombos(3) = Keys(1) & "|" & Keys(2) & "|"
saCombos(4) = "|" & Keys(2) & "|" & Keys(3)
GetKeyCombos = saCombos
End Function
06-18-2018, 04:59 AM
Excel Macro: Duplicate Finder
Similar Threads
Acronym Finder Macro for Microsoft Word
Windows 10 
Office 2010 32bit
Linear Mode
