Optimization VBA text search

Question

I created a VBA code for text analysis, but I encountered a problem at run time. I just found on Google an advice on using excel built in function, but it did not improve the run time.

Here is the problem for which I use VBA. I've got a list of ~30k cells containing text (one or two sentences on average) and a list of 1k keywords, all of them having a numeric score. For every of the 30k cells, I want to see which of the keywords the cell contains, and calculate the sum of the scores of the keywords found.

Here is my way of approaching the problem in a nutshell right now :

Loop on the 30k text cells
Loop on the keywords
Check if the keyword is in the text cell, if yes, add the score of the keyword

I also tried using the search built in function :

Loop on the keywords
Search the keywords on the entire sheet containing the 30k text cells
When the keyword is found, add the score on the corresponding cell.

There was no significant change in run time.

Below you can find my code for the first approach:

'Loop on all the 30k text cells
For i = 2 To last_textcell

    'loop on the number of different category of scores, setting intial scores to zero.
    For k = 1 To nb_score - 1
        Score(k) = 0
    Next k

    j = 2

    'loop on the 1k keywords        
    Do While j < last_keywords

            !search if the keyword is in the text cell
            If UCase(Sheets("DATA").Range("V" & i).Value) Like "*" & UCase(Sheets("Keywords").Range("A" & j).Value) & "*" Then

                'if the keyword is found, add the score of the keyword to the previous score
                For l = 1 To nb_score - 1
                    Score(l) = Score(l) + Sheets("Keywords").Range("B" & j).Offset(0, l - 1).Value
                Next l

            End If

            j = j + 1

    Loop

    'paste the score 
    For k = 1 To nb_categ - 1
        Sheets("DATA").Range("CO" & i).Offset(0, k - 1).Value = Score(k)
    Next k


Next i

Do you have any tips on how to improve the performance?

Thank you very much!

You could do this with an array formula I think, which might be better — Nathan_Sav, Jul 11 '16 at 08:34
See my post here on what you are doing inefficiently - http://stackoverflow.com/questions/29596432/pointers-needed-for-speeding-up-nested-loop-macro-in-vba/29597193#29597193 - dots, dots, dots. — , Jul 11 '16 at 10:26
Also consider removing `UCase`. It's a function call (so slow) and it seems unnecessary, particularly if called 30,000 times. — , Jul 11 '16 at 10:28

score 1 · Answer 1 · answered Jul 11 '16 at 08:43

1

Using an array, with the data to search in A1:A3, the keywords in C1:C3 and the scores in D1:D3

Can use the following array in Column E

=SUM(IFERROR(INDEX($D$1:$D$3,--(IF(NOT(ISERROR(SEARCH($C$1:$C$3,A1))),ROW($C$1:$C$3))),1),0))

answered Jul 11 '16 at 08:43

Nathan_Sav

8,466
2
13
20

score 0 · Accepted Answer · answered Jul 11 '16 at 09:39

I'd suggest two optimizations:

Load both the lists of sentences, and keywords, into memory before running the test. This means that you only request data from the sheet once, rather than for every iteration of the test.
Use the InStr function with vbTextCompare to find an instance of a keyword.

Here's the sample code - I left stubs for you to re-insert your scoring function code:

Option Explicit

Sub QuickTest()

    Dim wsKeywords As Worksheet
    Dim wsData As Worksheet
    Dim lngLastRow As Long
    Dim varKeywords As Variant
    Dim varData As Variant
    Dim lngSentenceCounter As Long
    Dim lngKeywordCounter As Long

    Set wsKeywords = ThisWorkbook.Worksheets("Keywords")
    Set wsData = ThisWorkbook.Worksheets("DATA")

    'get list of keywords in memory
    lngLastRow = wsKeywords.Cells(wsKeywords.Rows.Count, "B").End(xlUp).Row
    varKeywords = wsKeywords.Range("B2:B" & lngLastRow).Value

    'get data in memory
    lngLastRow = wsData.Cells(wsData.Rows.Count, "V").End(xlUp).Row
    varData = wsData.Range("V2:V" & lngLastRow).Value

    'your scoring setup code goes here
    '...

    'iterate data
    For lngSentenceCounter = 1 To UBound(varData, 1)
        'iterate keywords
        For lngKeywordCounter = 1 To UBound(varKeywords, 1)
            'test
            If InStr(1, varData(lngSentenceCounter, 1), varKeywords(lngKeywordCounter, 1), vbTextCompare) > 0 Then
                'you have a hit!
                'do something with the score
            End If
        Next lngKeywordCounter
    Next lngSentenceCounter

    'your scoring output code goes here
    '...

End Sub

Thank you very much! It improved the performance by a factor of 4! — J. Andrew, Jul 11 '16 at 12:25

Optimization VBA text search

2 Answers2