View Single Post
 
Old 06-18-2018, 04:59 AM
Saucy_Moonbeams Saucy_Moonbeams is offline Windows 10 Office 2010 32bit
Novice
 
Join Date: Jun 2018
Posts: 2
Saucy_Moonbeams is on a distinguished road
Post Excel Macro: Duplicate Finder

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 LonglRowEnd As LonglItem As Long
Dim saKey
() As StringsKey As String
Dim saKeyCombos
() As String
Dim sngPercent 
As Single
Dim vCur 
As VariantvData 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(1iPtr)))
    
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$("|||"iPtr)
        
On Error Resume Next
        mobjDictionary
.Add Key:=sKeyItem:=lRow
        On Error 
GoTo 0
    Next iPtr
 
Next lRow
 
ReDim vData
(1 To 11 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(1iPtr)))
    
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$("|||"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
(11) = sngPercent
        vData
(12) = 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$(String1iPtr1))
    If 
sChar <> LCase$(sChar_
    
Or IsNumeric(sCharThen 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 
Attached Images
File Type: png Capture.PNG (4.9 KB, 17 views)
Reply With Quote