I think this works, if you want to move the code to another work book you`ll need to set a reference to Microsoft Scripting Runtime. Let me know if you need anything explaining.
Sub wordSubWordMatch()
Dim aWordDict As New Scripting.Dictionary
Dim aSubWordDict As New Scripting.Dictionary
Dim aRng As Range
Dim testStr As String
Dim wordStr As String
Dim subWord As String
Dim aCount As Integer
Dim bCount As Integer
Dim aWordCount As Integer
Dim bWordCount As Integer
Dim match As Integer
Dim subMatch As Integer
Dim lastRow As Long
Const B_LIST As Integer = 7 ' constants for column offsets
Const A_LIST As Integer = 1
Const A_MAP As Integer = 2
Const A_DESC As Integer = 3
Application.ScreenUpdating = False
Set aRng = Worksheets("Sheet1").Range("A1")
lastRow = aRng.Offset(65000, 0).End(xlUp).Row - 1
Set aRng = aRng.Offset(1, 2).Resize(lastRow, 2)
aRng.ClearContents
Set aRng = Worksheets("Sheet1").Range("A1")
aCount = 1
Do Until aCount > lastRow
testStr = LCase(Trim(aRng.Offset(aCount, A_LIST)))
Do While Len(testStr) > 0
If InStr(testStr, "+") > 0 Then
wordStr = Left(testStr, (InStr(testStr, "+") - 1))
subWord = subTest(wordStr)
testStr = Right(testStr, Len(testStr) - (Len(wordStr) + 1))
Else
wordStr = testStr
subWord = subTest(wordStr)
testStr = ""
End If
If Not (aWordDict.Exists(wordStr)) Then
aWordDict.Add wordStr, aCount
End If
If subWord <> "" And Not (aSubWordDict.Exists(subWord)) Then
aSubWordDict.Add subWord, aCount
End If
Loop
aWordCount = aWordDict.Count
bCount = 1
wordStr = ""
subWord = ""
Do
bWordCount = 0
testStr = LCase(Trim(aRng.Offset(bCount, B_LIST)))
match = 0
subMatch = 0
Do While Len(testStr) > 0
If InStr(testStr, "+") > 0 Then
wordStr = Left(testStr, (InStr(testStr, "+") - 1))
subWord = subTest(wordStr)
testStr = Right(testStr, Len(testStr) - (Len(wordStr) + 1))
bWordCount = bWordCount + 1
Else
wordStr = testStr
subWord = subTest(wordStr)
bWordCount = bWordCount + 1
testStr = ""
End If
If aWordDict.Exists(wordStr) Then
match = match + 1
End If
If aSubWordDict.Exists(subWord) Or aSubWordDict.Exists(wordStr) _
Or aWordDict.Exists(subWord) Then
subMatch = subMatch + 1
End If
Loop
If match = aWordCount And bWordCount = aWordCount Then
aRng.Offset(aCount, A_MAP) = bCount
aRng.Offset(aCount, A_DESC) = "Exact"
GoTo Found
Else
If match + subMatch = aWordCount And aWordCount = bWordCount Then
aRng.Offset(aCount, A_MAP) = bCount
aRng.Offset(aCount, A_DESC) = "Partial"
GoTo Found
End If
End If
bCount = bCount + 1
Loop Until aRng.Offset(bCount, B_LIST) = ""
Found:
aCount = aCount + 1
aWordDict.RemoveAll
aSubWordDict.RemoveAll
testStr = ""
wordStr = ""
subWord = ""
If aRng.Offset(aCount, A_DESC) = "" Then
aRng.Offset(aCount, A_MAP) = "Not Found"
End If
Loop
aRng.Offset(lastRow + 1, 2) = ""
Set aWordDict = Nothing
Set aSubWordDict = Nothing
Application.ScreenUpdating = True
End Sub
Function subTest(testStr As String) As String
If InStr(testStr, " ") > 0 Then
subTest = Left(testStr, (InStr(testStr, " ") - 1))
End If
End Function
Regards
Ian
Bookmarks