Option Explicit
Const miResultsStartColumn As Integer = 1 'Output results starting in column A
Const msInputSheet As String = "Sheet1"
Const msOutputSheet As String = "Sheet2"
Const msngThresholdValue As Single = 0.5 'Threshold value of 50%
Const msLookupTableColumn As String = "A" 'Column A for lookup table
Const msLookupValueColumn As String = "B" 'Column B for lookup values
Const mlDataStartRow As Long = 3 'start of data in input & output sheet
Type RankInfo
Offset As Long
Percentage As Single
End Type
Dim mudRankData() As RankInfo
Dim mlBestMatchPtr As Long
Dim TopMatch As Long
Dim strCompare As String
Function FuzzyPercent(ByVal String1 As String, _
ByVal String2 As String, _
Optional Algorithm As Integer = 3, _
Optional Normalised As Boolean = False) As Single
'*************************************
'** Return a % match on two strings **
'*************************************
Dim intLen1 As Integer, intLen2 As Integer
Dim intCurLen As Integer
Dim intTo As Integer
Dim intPos As Integer
Dim intPtr As Integer
Dim intScore As Integer
Dim intTotScore As Integer
Dim intStartPos As Integer
Dim sngScore As Single
Dim strWork As String
'-------------------------------------------------------
'-- If strings havent been normalised, normalise them --
'-------------------------------------------------------
If Normalised = False Then
String1 = LCase$(Application.Trim(String1))
String2 = LCase$(Application.Trim(String2))
End If
'----------------------------------------------
'-- Give 100% match if strings exactly equal --
'----------------------------------------------
If String1 = String2 Then
FuzzyPercent = 1
Exit Function
End If
intLen1 = Len(String1)
intLen2 = Len(String2)
If intLen1 = 0 Or intLen2 = 0 Then
FuzzyPercent = 0
Exit Function
End If
'----------------------------------------
'-- Give 0% match if string length < 2 --
'----------------------------------------
If intLen1 < 2 Then
FuzzyPercent = 0
Exit Function
End If
intTotScore = 0 'initialise total possible score
intScore = 0 'initialise current score
'--------------------------------------------------------
'-- If Algorithm = 1 or 3, Search for single characters --
'--------------------------------------------------------
If (Algorithm And 1) <> 0 Then
If intLen1 < intLen2 Then
FuzzyAlg1 String1, String2, intScore, intTotScore
Else
FuzzyAlg1 String2, String1, intScore, intTotScore
End If
End If
'-----------------------------------------------------------
'-- If Algorithm = 2 or 3, Search for pairs, triplets etc. --
'-----------------------------------------------------------
If (Algorithm And 2) <> 0 Then
If intLen1 < intLen2 Then
FuzzyAlg2 String1, String2, intScore, intTotScore
Else
FuzzyAlg2 String2, String1, intScore, intTotScore
End If
End If
'------------------------------------------------------
'-- If Algorithm = 4,5,6,7, use Dan Ostander's code. --
'------------------------------------------------------
'If (Algorithm And 4) <> 0 Then
' If intLen1 < intLen2 Then
' sngScore = FuzzyAlg4(String1, String1)
' Else
' sngScore = FuzzyAlg4(String2, String1)
' End If
' intScore = intScore + (sngScore * 100)
' intTotScore = intTotScore + 100
'End If
FuzzyPercent = intScore / intTotScore
End Function
Private Sub FuzzyAlg1(ByVal String1 As String, _
ByVal String2 As String, _
ByRef Score As Integer, _
ByRef TotScore As Integer)
Dim intLen1 As Integer, intPos As Integer, intPtr As Integer, intStartPos As Integer
intLen1 = Len(String1)
TotScore = TotScore + intLen1 'update total possible score
intPos = 0
For intPtr = 1 To intLen1
intStartPos = intPos + 1
intPos = InStr(intStartPos, String2, Mid$(String1, intPtr, 1))
If intPos > 0 Then
If intPos > intStartPos + 3 Then 'No match if char is > 3 bytes away
intPos = intStartPos
Else
Score = Score + 1 'Update current score
End If
Else
intPos = intStartPos
End If
Next intPtr
End Sub
Private Sub FuzzyAlg2(ByVal String1 As String, _
ByVal String2 As String, _
ByRef Score As Integer, _
ByRef TotScore As Integer)
Dim intCurLen As Integer, intLen1 As Integer, intTo As Integer, intPtr As Integer, intPos As Integer
Dim strWork As String
intLen1 = Len(String1)
For intCurLen = 1 To intLen1
strWork = String2 'Get a copy of String2
intTo = intLen1 - intCurLen + 1
TotScore = TotScore + Int(intLen1 / intCurLen) 'Update total possible score
For intPtr = 1 To intTo Step intCurLen
intPos = InStr(strWork, Mid$(String1, intPtr, intCurLen))
If intPos > 0 Then
Mid$(strWork, intPos, intCurLen) = String$(intCurLen, &H0) 'corrupt found string
Score = Score + 1 'Update current score
End If
Next intPtr
Next intCurLen
End Sub
Private Function FuzzyAlg4(strIn1 As String, strIn2 As String) As Single
'Dim L1 As Integer
'Dim In1Mask(1 To 24) As Long 'strIn1 is 24 characters max
'Dim iCh As Integer
'Dim N As Long
'Dim strTry As String
'Dim strTest As String
'
'TopMatch = 0
'L1 = Len(strIn1)
'strTest = UCase(strIn1)
'strCompare = UCase(strIn2)
'For iCh = 1 To L1
' In1Mask(iCh) = 2 ^ iCh
'Next iCh 'Loop thru all ordered combinations of characters in strIn1
'For N = 2 ^ (L1 + 1) - 1 To 1 Step -1
' strTry = ""
' For iCh = 1 To L1
' If In1Mask(iCh) And N Then
' strTry = strTry & Mid(strTest, iCh, 1)
' End If
' Next iCh
' If Len(strTry) > TopMatch Then FuzzyAlg4Test strTry
'Next N
'FuzzyAlg4 = TopMatch / CSng(L1)
End Function
Sub GetAddresses()
Dim iResultsColumn As Integer
Dim lLookupValuesRow As Long
Dim lLookupTableRow As Long
Dim lResultsRow As Long
Dim lNextProgressReport As Long
Dim lProgressReportTrigger As Long
Dim sCurrentLookupValue As String
Dim sCurrentTableValue As String
Dim sngCurrentPercent As Single
Dim vaLookupTable As Variant
Dim vaLookupValues As Variant
Dim vaResults As Variant
Dim wsInput As Worksheet
Dim wsOutput As Worksheet
Set wsInput = Sheets(msInputSheet)
Set wsOutput = Sheets(msOutputSheet)
With wsInput
vaLookupTable = Intersect(.UsedRange, .Columns(msLookupTableColumn))
vaLookupValues = Intersect(.UsedRange, .Columns(msLookupValueColumn))
End With
wsOutput.UsedRange.ClearContents
iResultsColumn = miResultsStartColumn
lResultsRow = 0
ReDim vaResults(1 To 1, 1 To 1)
lProgressReportTrigger = Int(UBound(vaLookupValues, 1) / 100)
lNextProgressReport = 0
For lLookupValuesRow = mlDataStartRow To UBound(vaLookupValues, 1)
If lLookupValuesRow >= lNextProgressReport Then
Application.StatusBar = "Processing row " & lLookupValuesRow & " of " & UBound(vaLookupValues, 1)
lNextProgressReport = lLookupValuesRow + lProgressReportTrigger
End If
sCurrentLookupValue = WorksheetFunction.Trim(LCase$(CStr(vaLookupValues(lLookupValuesRow, 1))))
For lLookupTableRow = mlDataStartRow To UBound(vaLookupTable, 1)
sCurrentTableValue = WorksheetFunction.Trim(LCase$(CStr(vaLookupTable(lLookupTableRow, 1))))
sngCurrentPercent = FuzzyPercent(String1:=sCurrentLookupValue, _
String2:=sCurrentTableValue, _
Algorithm:=2, _
Normalised:=True)
If sngCurrentPercent >= msngThresholdValue Then
lResultsRow = lResultsRow + 1
ReDim Preserve vaResults(1 To 1, 1 To lResultsRow)
vaResults(1, lResultsRow) = vaLookupTable(lLookupTableRow, 1)
End If
Next lLookupTableRow
Next lLookupValuesRow
With wsOutput
.Range(.Cells(mlDataStartRow, iResultsColumn).Address).Resize(UBound(vaResults, 2), 1).Value = WorksheetFunction.Transpose(vaResults)
End With
Application.StatusBar = False
End Sub
