VBA: MATCH not working

Excel_Novice_

New Member
Joined
Jun 19, 2018
Messages
2
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. like this:

[TABLE="class: grid, width: 500, align: center"]
<tbody>[TR]
[TD]Percent Match[/TD]
[TD]Row Match[/TD]
[TD]Name[/TD]
[/TR]
[TR]
[TD]88%[/TD]
[TD]7[/TD]
[TD]Nike[/TD]
[/TR]
[TR]
[TD]90%[/TD]
[TD]6[/TD]
[TD]3M[/TD]
[/TR]
[TR]
[TD]99%[/TD]
[TD]5[/TD]
[TD]Adidas[/TD]
[/TR]
[TR]
[TD]99%[/TD]
[TD]4[/TD]
[TD]adidas[/TD]
[/TR]
[TR]
[TD]90%[/TD]
[TD]6[/TD]
[TD]Three M[/TD]
[/TR]
[TR]
[TD]88%[/TD]
[TD]2[/TD]
[TD] Nike[/TD]
[/TR]
</tbody>[/TABLE]


I have been trying to modify this code to do so, but it wont run, Any help on this would be appreciated

PHP:
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
 

Excel Facts

Shade all formula cells
To shade all formula cells: Home, Find & Select, Formulas to select all formulas. Then apply a light fill color.

Forum statistics

Threads
1,223,240
Messages
6,170,951
Members
452,368
Latest member
jayp2104

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top