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

Open in new window

test2509a.xlsm
Sunil KakkarAsked:
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.

Saqib Husain, SyedEngineerCommented:
Hi, can you please explain what you are using clm for?
0
Saqib Husain, SyedEngineerCommented:
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

Your issues matter to us.

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

Start your 7-day free trial
Sunil KakkarAuthor 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.
Look forward to your solution.
0
Cloud Class® Course: Microsoft Windows 7 Basic

This introductory course to Windows 7 environment will teach you about working with the Windows operating system. You will learn about basic functions including start menu; the desktop; managing files, folders, and libraries.

Sunil KakkarAuthor Commented:
Speedy response. Highly professional program. Very cooperative person.
0
Sunil KakkarAuthor Commented:
Hi, Saqib Husain, Syed
This is the program I was looking for. My heartfelt thanks to you.

Sunil
0
Ejgil HedegaardCommented:
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

Open in new window

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.