# Matching words from two title and calculate %

I am 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 following code and it is giving accurate results in % terms. My specific purpose of this query is to explore  whether there could be a better code to do it more efficiently, If the data size is large say more than 50 K rows.

``````Sub percentage()

Dim a() As String
Dim b() As String
Dim aRng As Range
Dim cel As Range
Dim i As Integer, t As Integer, clm As Integer

Set aRng = Range(Range("A1"), Range("A5").End(xlDown))

For Each cel In aRng
a = Split(cel, " ")
b = Split(cel.Offset(, 1), " ")
d = 0
clm = 2
c = UBound(a) + 1 'changed here
If cel.Value <> "" Then
For i = LBound(a) To UBound(a)

For t = LBound(b) To UBound(b)
If UCase(a(i)) = UCase(b(t)) Then
clm = 2
Do While True
If UCase(cel.Offset(, clm)) = UCase(a(i)) Then
Exit Do
End If
If cel.Offset(, clm) = "" Then
'cel.Offset(, clm) = a(i)
Exit Do
End If
clm = clm + 1
Loop
d = d + 1
'MsgBox a(i)
'MsgBox b(i)
End If

Next

Next
Debug.Print d
Debug.Print c
cel.Offset(0, 2).Value = (d / c) * 100 'multiply by 100 for percentage
End If
Next

End Sub
``````
test2509a.xlsm
###### Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

EngineerCommented:
Hi, can you please explain what you are using clm for?
0
EngineerCommented:
Try this modification

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 'change here

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) * 100 'multiply by 100 for percentage
Next
End Sub
0

Experts Exchange Solution brought to you by

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Author Commented:
Hi,
I am happy to have received a response from you. This was a question on another forum from  a newbie and to solve his problem I created a fictitious data and debugged it to solve the problem. While solving the problem I wondered whether looping is optimal or there could be some way such as processing in arrays (i.e. in memory) , dictionary may be a more efficient approach. Since my level in VBA is also elementary I have posed this question. If there is a better approach then what could be the coding for that.
0
Author Commented:
Speedy response. Highly professional program. Very cooperative person.
0
Author Commented:
Hi, Saqib Husain, Syed
This is the program I was looking for. My heartfelt thanks to you.

Sunil
0
Commented:
Another method.
It loads the ranges into arrays and do the calculation "in memory", and when finished, write the entire result back to the sheet, instead of cell by cell.
Tested with 50,000 rows, and it took about 4 seconds.
The macro write all 3 columns C, D and E, in case you want to know the number of words in A and B.
The macro is in Module2, press the button to run.
``````Option Explicit

Sub FindPercentage()
Dim ws As Worksheet
Dim rgIn() As Variant, rgOut() As Variant
Dim WordsA() As String, WordsB() As String
Dim rw As Long, rwMax As Long
Dim NbrMatchWords As Integer
Dim i As Integer, j As Integer
Set ws = Worksheets("Sheet1")
ws.Select
rwMax = ws.Range("A1").CurrentRegion.Rows.Count
rgIn = ws.Range("A1:B" & rwMax)
rgOut = ws.Range("C1:E" & rwMax)
For rw = 2 To rwMax
WordsA = Split(Trim(rgIn(rw, 1)), " ")
WordsB = Split(Trim(rgIn(rw, 2)), " ")
NbrMatchWords = 0
For i = 0 To UBound(WordsA)
For j = 0 To UBound(WordsB)
If UCase(WordsA(i)) = UCase(WordsB(j)) Then
NbrMatchWords = NbrMatchWords + 1
End If
Next j
Next i
If UBound(WordsA) >= 0 Then
rgOut(rw, 1) = NbrMatchWords / (UBound(WordsA) + 1) * 100
Else
rgOut(rw, 1) = ""
End If
rgOut(rw, 2) = UBound(WordsA) + 1
rgOut(rw, 3) = UBound(WordsB) + 1
Next rw
ws.Range("C1:E" & rwMax) = rgOut
End Sub
``````
test2509a-1.xlsm
0
###### It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Excel

From novice to tech pro — start learning today.

Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.