Пребройте и маркирайте ключови думи във фрази

Възможно е да успеете да съберете ефективно преброяване с модулна подпроцедура, която изпълнява всички математически изчисления в масиви от памет¹ и връща преброяванията в работния лист.

Използвах някои стандартни ключови думи и фрази Lorem Ipsum, за да създам горните примерни данни.

Докоснете Alt+F11 и когато VBE се отвори, веднага използвайте падащите менюта, за да вмъкнете ► модул (Alt+I< /kbd>,M). Поставете следното в новия лист с код на модул, озаглавен нещо като Book1 - Module1 (код).

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^ти кодов ред. Включих също помощна рутина, която идентифицира ключовите думи във фразите със син|удебелен шрифт. Коментирайте или изтрийте реда Call key_in_phrase_helper(...) в долната част на първата подпроцедура, ако това не е желано.

Докоснете Alt+Q, за да се върнете към вашия работен лист. Докоснете Alt+F8, за да отворите диалоговия прозорец Макроси и Изпълни подпроцедурата. Ако вашите данни приличат на примерните данни, които събрах, тогава трябва да имате подобни резултати.

¹ _{Това са някои усъвършенствани методи, но смятам, че те са и най-добрият начин да се справите с проблема си. Ако имате специфични въпроси, които вашите собствени изследвания не обясняват адекватно, ще се опитам да отговоря на тях в секцията за коментари. Примерната работна книга, която създадох, за да създам това решение, може да бъде предоставена при поискване.}

Можете да използвате тази формула COUNTIF(B:B;"*"&A2&"*") като започнете от втория ред.