Matching two titles by words and calculate % - excel

Question

I was trying to automate an Excel file which has title in both A and B columns and I have to search each word from A within B and calculate the % by using the "no of words matched/total no of words (in column A)" formula.
I'm using the below code, however its not giving me the accurate % for which the title has repeated words (Duplicate words).
Sub percentage()
Dim a() As String, b() As String
Dim aRng As Range, cel As Range
Dim i As Integer, t As Integer
Set aRng = Range(Range("A1"), Range("A5").End(xlDown))
For Each cel In aRng
a = Split(Trim(cel), " ")
b = Split(Trim(cel.Offset(, 1)), " ")
d = 0
c = UBound(a) + 1
If cel.Value <> "" Then
If InStr(cel, cel.Offset(, 1)) Then
d = UBound(b) + 1
Else
For i = LBound(a) To UBound(a)
For t = LBound(b) To UBound(b)
If UCase(a(i)) = UCase(b(t)) Then
d = d + 1
End If
Next
Next
End If
End If
cel.Offset(0, 2).Value = (d / c)
Next
End Sub
If Title 1 : Really Nice pack with Nice print and Title 2 : Nice Print Nice pack then result should be 3/6 i.e. 67%.
But I'm getting a result as 100%.
Can anyone help me out please.
Titles are
Great job dud
Really Nice pack with Nice print
To give success and success process
Don’t eat too much. If you eat too much you will get sick
I have tried =noDuplicate(celladdress)

Answer 1

First, you should delete duplicate word in column B.
My function delete word and return array of word that not duplicate.
Function noDuplicate(ByVal str As String) As String()
Dim splitStr() As String
Dim result() As String
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim addFlag As Boolean
splitStr = Split(UCase(str), " ")
ReDim result(UBound(splitStr))
'
result(0) = splitStr(0)
k = 0
For i = 1 To UBound(splitStr)
addFlag = True
For j = 0 To k
If splitStr(i) = result(j) Then
addFlag = False
Exit For
End If
Next j
If addFlag Then
result(k + 1) = splitStr(i)
k = k + 1
End If
Next i
ReDim Preserve result(k)
noDuplicate = result
End Function
Then calculate the percentage of number of match word and number of word in column A.
Function percentMatch(ByVal colA As String, ByVal colB As String) As Double
Dim splitColA() As String
Dim splitColB() As String
Dim i As Integer
Dim j As Integer
Dim matchCount As Integer
splitColA = Split(UCase(colA), " ")
splitColB = noDuplicate(colB)
matchCount = 0
For i = 0 To UBound(splitColA)
For j = 0 To UBound(splitColB)
If splitColA(i) = splitColB(j) Then
matchCount = matchCount + 1
Exit For
End If
Next j
Next i
percentMatch = matchCount / (UBound(splitColA) + 1)
End Function
After add these two function, you can write your new code to below
Sub percentage()
Dim aRng As Range, cel As Range
Set aRng = Range(Range("A1"), Range("A5").End(xlDown))
For Each cel In aRng
cel.Offset(0, 2).Value = percentMatch(cel.Value, cel.Offset(0, 1).Value)
Next
End Sub
Note, I not protect for empty string in the function.

Answer 2

If you F8 through the code, you can see the problem.
The first Nice in column A loops through column B and counts 2 occurences.
Pack in column A loops through column B and counts 1 occurence.
The second Nice in column A loops through column B and counts 2 occurences.
Print in column A loops through column B and counts 1 occurence.
So you get a count of 6 against the 6 words in column A; 100%
If you add a random word to column A, you'll get 6 out of 7.