优化 VBA 文本搜索

Question

我创建了一个VBA代码用于文本分析，但我在运行时遇到了问题。我刚刚在 Google 上找到了关于使用 excel 内置函数的建议，但它并没有改善运行时间。

这是我用 VBA 解决的问题。我有一个约 30k 单元格的列表，其中包含文本（平均一两个句子）和一个 1k 关键字的列表，所有这些都有一个数字分数。对于30k个单元格中的每一个，我想查看该单元格包含哪些关键字，并计算找到的关键字的分数之和。

这是我现在简要地解决问题的方法：

在 30k 文本单元格上循环
循环关键字
检查关键字是否在文本单元格中，如果是，加上关键字的分数

我也试过使用内置搜索功能：

循环关键字
在包含 30k 个文本单元格的整个 sheet 中搜索关键字
找到关键字后，在相应的单元格上添加分数。

运行时间无明显变化。

您可以在下面找到第一种方法的代码：

'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

关于如何提高性能，您有什么建议吗？

非常感谢！

Answer 1

使用数组，搜索数据在A1:A3，关键字在C1:C3，分数在D1:D3

E列可以使用如下数组

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

Answer 2

我建议两个优化：

在运行测试之前将句子列表和关键字加载到内存中。这意味着您只从 sheet 请求数据一次，而不是每次测试迭代。
使用 InStr 函数和 vbTextCompare 查找关键字实例。

这是示例代码 - 我留下了存根供您重新插入评分函数代码：

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

优化 VBA 文本搜索

Optimization VBA text search

excel

optimization

vba

text-search