Counting bolded words/series of words in cell strings.

[Pquigrafamos]

Hello!
I would like to ask for advice on the optimization of a macro to count words/series of words contained in a string.
Examples:
In this example, two counts should be made-> Count: 2
In this example, two counts should be made-> Count: 2
In ( example ) two counts should be made -> Count: 2

Sheet setting:

Language​	Text​	Results expected​	Macro result​	Match?​
English​	This article will take a look at the potential health benefits of bananas, such as improving heart health and promoting regularity. It also examines the ( possible ) health risks that doctors have associated with bananas.​	4​		FALSE​
Czech​	Tento článek se podívá na potenciální zdravotní přínosy banánů, jako je zlepšení zdraví srdce a podpora pravidelnosti. Zkoumá také ( možná ) zdravotní rizika, která lékaři spojují s banány.​	4​		FALSE​
Bulgarian​	Тази статия ще разгледа потенциалните ползи за здравето от бананите, като подобряване на здравето на сърцето и насърчаване на редовността. Той също така разглежда ( възможните ) рискове за здравето, които лекарите свързват с бананите.​	4​		FALSE​
Arabic​	ستلقي هذه المقالة نظرة على الفوائد الصحية المحتملة للموز ، مثل تحسين صحة القلب وتعزيز الانتظام. كما يبحث في المخاطر الصحية ( المحتملة ) التي يربطها الأطباء بالموز.​	4​		FALSE​

(The files being worked on have more than 30 lines such as these)

I have developed the following solution that is accurate, the issue is that it takes too much time for the comparison to be made, as it is going character by character:

Sub Test1()
Application.EnableEvents = False
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

    Dim lDq As Worksheet
    Dim IngdL1, bWc As Range    
    Set lDq = ActiveSheet
    Dim d, f, a, n, i, q As Integer
    Dim boo1 As Boolean
        
    Set IngdL1 = lDq.Rows(1).Find("text", , xlValues, xlWhole)
    Set bWc = lDq.Cells(1, 4)
    bWc = "Macro result"
    bWc.WrapText = True
    d = 0
    f = lDq.Cells(Rows.Count, 1).End(xlUp).Row
    For a = 1 To f
        If IngdL1.Offset(a, 0).Value <> "" Then
            For n = 1 To Len(IngdL1.Offset(a, 0))
                If IngdL1.Offset(a, 0).Characters(n, 1).Font.FontStyle = "Bold" Then
                    d = d + 1
                    Do Until IngdL1.Offset(a, 0).Characters(n, 1).Font.FontStyle <> "Bold" Or n >= Len(IngdL1.Offset(a, 0))
                        n = n + 1
                    Loop
                End If
            Next n
            bWc.Offset(a, 0) = d
        End If
        d = 0
    Next a
        
    i = 0
    n = 0
    boo1 = True
    For a = 1 To f
        If bWc.Offset(a, 0) <> "" Then
            i = i + 1
            q = bWc.Offset(a, 0)
            If i <> 1 Then
                If n <> q Then
                    boo1 = False
                End If
            End If
        End If
        n = q
    Next a
    If boo1 = False Then
        lDq.Cells(5, 11) = "1 - A different number of bolded words was detected between languages"
        lDq.Range(lDq.Cells(5, 11), lDq.Cells(5, 25)).Interior.Color = 13431551
    End If
    If boo1 = True Then
        lDq.Cells(5, 11) = "1 - Matching number of bolded words between languages: " & q & " words; " & i & " languages."
    End If
    
Application.EnableEvents = True
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

Following an example found online, I tried several options with the Regex. It is much faster, but nothing seems to match the specificity of the requirements (Alternative character languages; spaces between terms):

Sub Test2()
Application.EnableEvents = False
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

    Dim lDq As Worksheet
    Dim IngdL1, bWc As Range
    
    Set lDq = ActiveSheet
    Dim d, f, a, n, i, q As Integer
    Dim boo1 As Boolean
    
    
    Set IngdL1 = lDq.Rows(1).Find("text", , xlValues, xlWhole)
    Set bWc = lDq.Cells(1, 4)
    bWc = "Macro result"
    bWc.WrapText = True
    d = 0
    f = lDq.Cells(Rows.Count, 1).End(xlUp).Row
    Dim Rng As Range
    Dim sPattern As String
    Dim oRegExp, oMatches, oMatch As Object
    Dim Counter As Long
    'sPattern = "\w+"
    'sPattern = "\W+"
    'sPattern = "\d+"
    'sPattern = "\D+"
    'sPattern = "\s+"
    sPattern = "\S+"
    
For a = 1 To f
    Counter = 0
    Set Rng = IngdL1.Offset(a, 0)
    Set oRegExp = CreateObject("VBScript.RegExp")
    With oRegExp
        .Pattern = sPattern
        .Global = True
        Set oMatches = .Execute(Rng)
        For Each oMatch In oMatches
            If Rng.Characters(oMatch.FirstIndex + 1, oMatch.Length).Font.Bold Then Counter = Counter + 1
        Next
    End With
    If IngdL1.Offset(a, 0) <> "" Then
        bWc.Offset(a, 0) = Counter
    End If
Next a

    i = 0
    n = 0
    boo1 = True
    For a = 1 To f
        If bWc.Offset(a, 0) <> "" Then
            i = i + 1
            q = bWc.Offset(a, 0)
            If i <> 1 Then
                If n <> q Then
                    boo1 = False
                End If
            End If
        End If
        n = q
    Next a
    If boo1 = False Then
        lDq.Cells(5, 11) = "1 - A different number of bolded words was detected between languages"
        lDq.Range(lDq.Cells(5, 11), lDq.Cells(5, 25)).Interior.Color = 13431551
    End If
    If boo1 = True Then
        lDq.Cells(5, 11) = "1 - Matching number of bolded words between languages: " & q & " words; " & i & " languages."
    End If
    
Application.EnableEvents = True
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

I would like then to ask if someone more experienced can share a tip to optimize this macro.
Best regards!

 

[lrobbo314]

How about this?

Book1
	A	B
28	4	This article will take a look at the potential health benefits of bananas, such as improving heart health and promoting regularity. It also examines the ( possible ) health risks that doctors have associated with bananas.
29	4	Tento článek se podívá na potenciální zdravotní přínosy banánů, jako je zlepšení zdraví srdce a podpora pravidelnosti. Zkoumá také ( možná ) zdravotní rizika, která lékaři spojují s banány.
30	4	Тази статия ще разгледа потенциалните ползи за здравето от бананите, като подобряване на здравето на сърцето и насърчаване на редовността. Той също така разглежда ( възможните ) рискове за здравето, които лекарите свързват с бананите.
Sheet1

Cell Formulas
Range	Formula
A28:A30	A28	=bx(B28)

Function BX(r As Range)
Dim b As Boolean:   b = False
Dim CNT As Integer: CNT = 0

For i = 2 To Len(r.Text)
    If r.Characters(i, 1).Font.Bold = True Then
        b = True
    Else
        If b = True Then CNT = CNT + 1
        b = False
    End If
Next i

If b Then CNT = CNT + 1
BX = CNT
End Function

 

[Pquigrafamos]

@lrobbo314, many thanks, your solution is certainly more elegant than mine (Test1)
I have adapted it to my aim and tested it. It is accurate and slightly faster than my Test1. So I will be using it for now!
Unfortunately, for the intended purpose, it still takes too long to complete the actions.
I still wonder if it is possible to find a faster alternative, I will keep searching.
Once again, many thanks for your help!