Option Explicit
Const miDataColumns As Integer = 15 'No of data columns
Const miKeycolumn As Integer = 14 'ID key column
Const miAltKeyColumn As Integer = 1 'Alternative key column
Const miPercentcolumn As Integer = 16 'Column required to put % result
Const miMatchRowColumn As Integer = 17 'Column required for Match Row result
Const msWorksheet As String = "Sheet1"
Dim mobjMainDictionary As Object
Dim mobjAltDictionary As Object
Sub GetMatches()
Dim iPtr As Integer, iScore As Integer
Dim lRow As Long, lRowEnd As Long
Dim sCurKey As String, sCurAltKey As String, sMatchKey As String
Dim vData As Variant, vItem As Variant, vCurItem As Variant
Dim WS As Worksheet
Set WS = Sheets(msWorksheet)
lRowEnd = WS.Cells(Rows.Count, miKeycolumn).End(xlUp).Row
Set mobjMainDictionary = Nothing
Set mobjMainDictionary = CreateObject("Scripting.Dictionary")
Set mobjAltDictionary = Nothing
Set mobjAltDictionary = CreateObject("Scripting.Dictionary")
For lRow = 2 To lRowEnd
vData = WS.Range("A" & lRow, WS.Cells(lRow, miDataColumns).Address).Value
sCurKey = NormaliseKey(CStr(vData(1, miKeycolumn)))
sCurAltKey = NormaliseKey(CStr(vData(1, miAltKeyColumn)))
If sCurKey <> "" Or sCurAltKey <> "" Then
vCurItem = WorksheetFunction.Transpose(vData)
ReDim Preserve vCurItem(1 To miDataColumns, 1 To 2)
vCurItem(1, 2) = lRow
If sCurKey = "" Then
On Error Resume Next
sCurKey = mobjAltDictionary.Item(sCurAltKey)
On Error GoTo 0
End If
If sCurKey <> "" Then
If mobjMainDictionary.exists(sCurKey) = False Then
If mobjAltDictionary.exists(sCurAltKey) Then
sCurKey = mobjAltDictionary.Item(sCurAltKey)
Else
mobjMainDictionary.Add key:=sCurKey, Item:=vCurItem
End If
End If
vItem = mobjMainDictionary.Item(sCurKey)
If vItem(1, 2) <> lRow Then
iScore = 0
For iPtr = 1 To UBound(vItem, 1)
If vItem(iPtr, 1) = vCurItem(iPtr, 1) Then iScore = iScore + 1
Next iPtr
WS.Cells(lRow, miPercentcolumn).Value = Format(iScore / UBound(vItem, 1), "0.00%")
If miMatchRowColumn > 0 Then WS.Cells(lRow, miMatchRowColumn).Value = vItem(1, 2)
End If
End If
If sCurAltKey <> "" Then
If mobjAltDictionary.exists(sCurAltKey) = False Then mobjAltDictionary.Add key:=sCurAltKey, Item:=sCurKey
End If
End If
Next lRow
mobjMainDictionary.RemoveAll
Set mobjMainDictionary = Nothing
mobjAltDictionary.RemoveAll
Set mobjAltDictionary = 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
