计算并突出显示短语中的关键字

Question

我有一个包含两列的 excel sheet。第一列是关键短语，第二列是消息。关键短语可能出现在消息列中。我需要知道在消息列中出现了多少次关键短语。请提出一些简单易行的查找方法。

关键词是一栏，消息是第二栏。消息列是 1 个或多个关键短语的组合（串联）。我需要找出每条消息包含多少个关键短语。

Answer 1

您可以使用此公式 COUNTIF(B:B;"*"&A2&"*") 从第二行开始。

Answer 2

您可能能够使用模块子过程收集有效计数，该过程在内存数组中执行所有数学运算¹，return计算工作sheet。

我使用了一些标准 Lorem Ipsum 关键字和短语来创建上述示例数据。

点击 Alt+F11 并且当 VBE 打开时，立即使用 pull-down 菜单插入 ► 模块 (Alt+I,M)。将以下内容粘贴到新模块代码 sheet 中，标题类似于 Book1 - Module1 (Code).

Option Explicit

Sub count_strings_inside_strings()
    Dim rw As Long, lr As Long
    Dim k As Long, p As Long, vKEYs As Variant, vPHRASEs As Variant, vCOUNTs As Variant

    ReDim vKEYs(0)
    ReDim vPHRASEs(0)

    With Worksheets("Sheet1")   '<~~ set to the correct worksheet name\
        'populate the vKEYs array
        For rw = 2 To .Cells(Rows.Count, 1).End(xlUp).Row
            vKEYs(UBound(vKEYs)) = LCase(.Cells(rw, 1).Value2)
            ReDim Preserve vKEYs(UBound(vKEYs) + 1)
        Next rw
        ReDim Preserve vKEYs(UBound(vKEYs) - 1)

        'populate the vPHRASEs array
        For rw = 2 To .Cells(Rows.Count, 2).End(xlUp).Row
            vPHRASEs(UBound(vPHRASEs)) = LCase(.Cells(rw, 2).Value2)
            ReDim Preserve vPHRASEs(UBound(vPHRASEs) + 1)
        Next rw
        ReDim Preserve vPHRASEs(UBound(vPHRASEs) - 1)
        ReDim vCOUNTs(0 To UBound(vPHRASEs))

        'perform the counts
        For p = LBound(vPHRASEs) To UBound(vPHRASEs)
            For k = LBound(vKEYs) To UBound(vKEYs)
                vCOUNTs(p) = CInt(vCOUNTs(p)) + _
                    (Len(vPHRASEs(p)) - Len(Replace(vPHRASEs(p), vKEYs(k), vbNullString))) / Len(vKEYs(k))
            Next k
        Next p

        'return the counts to the worksheet
        .Cells(2, 3).Resize(UBound(vCOUNTs) + 1, 1) = Application.Transpose(vCOUNTs)

        'run the helper procedure to Blue|Bold all of the found keywords within the phrases
        Call key_in_phrase_helper(vKEYs, .Range(.Cells(2, 2), .Cells(Rows.Count, 2).End(xlUp)))

    End With
End Sub

Sub key_in_phrase_helper(vKYs As Variant, rPHRSs As Range)
    Dim p As Long, r As Long, v As Long

    With rPHRSs
        For r = 1 To rPHRSs.Rows.Count
            .Cells(r, 1) = .Cells(r, 1).Value2
            For v = LBound(vKYs) To UBound(vKYs)
                p = 0
                Do While CBool(InStr(p + 1, .Cells(r, 1).Value2, vKYs(v), vbTextCompare))
                    p = InStr(p + 1, .Cells(r, 1).Value2, vKYs(v), vbTextCompare)
                    Debug.Print vKYs(v)
                    With .Cells(r, 1).Characters(Start:=p, Length:=Len(vKYs(v))).Font
                        .Bold = True
                        .ColorIndex = 5
                    End With
                Loop
            Next v
        Next r
    End With
End Sub

您可能需要重命名要在第 5 代码行中处理的工作sheet。我还包含了一个辅助例程，它用 Blue|Bold 字体识别短语中的关键词。如果不需要，请注释掉或删除第一个子过程底部的 Call key_in_phrase_helper(...) 行。

点击 Alt+Q 以 return 进入你的工作sheet。点击 Alt+F8 打开 Macros 对话框和 运行 子程序。如果您的数据与我放在一起的示例数据相似，那么您应该会得到类似的结果。

¹ _{这些是一些高级方法，但我觉得它们也是解决您问题的最佳方法。如果您有具体问题而您自己的研究无法充分解释，我会尝试在评论部分解决这些问题。我为创建此解决方案而创建的示例工作簿可应要求提供。}

计算并突出显示短语中的关键字

Count and Highlight keywords within phrases

vba

excel

scripting

highlight