VBA: Formating specific text sections of a cell based on conditions.

[Pquigrafamos]

Hello, first post here

I have the following problem:

-I have extensive lists of sentences in Excel, in which there are words ending and beginning with <strong></strong>.
-Every day new words appear having these <strong></strong> remarks.
-There is the need of creating a macro to automatize this process.

An example of such cells:

<strong>Frog</strong> and also the <strong>dog</strong>

House animals such as the <strong>dog</strong>

Is appliable for the <strong>dog</strong>

Eating <strong>Bananas</strong>, and others

I am trying to find a way of making the words inside these marks (<strong></strong>) bold and in UPPERCASE.
A solution was found, which separates the text and concatenates it back as pretended. But this solution is not ideal, it is very heavy and it takes too much time to complete the task.
As such, the objective would be to set conditions that would format solely the words inside these remarks, making them bold and UPPERCASE, leaving the rest of the text as it was.

Hose animals such as the<strong>dog</strong> -> House animals such as the DOG

Does anyone know if this is possible?
Best regards

 

[bobsan42]

Try this code:

Option Explicit

Sub FormatStrings()
    Const btag = "strong"
    Const stag = "<" & btag & ">"
    Const etag = "</" & btag & ">"
    Dim rmTag As Boolean
    rmTag = vbYes = MsgBox("Do you want to remove the tags from the text?", vbYesNo + vbDefaultButton1 + vbQuestion, "Remove the tags or keep them?")
    
    Dim rng As Range, cc As Range
    Dim str As String, word As String
    Dim spos As Long, epos As Long
    
    Set rng = Selection
    For Each cc In rng
        With cc
            str = .Value
            If Len(str) = 0 Then GoTo skipcc
            spos = InStr(1, str, stag, vbTextCompare)
            Do While spos > 0
                If rmTag Then .Characters(spos, Len(stag)).Delete Else spos = spos + Len(stag)
                epos = InStr(spos, .Value, etag, vbTextCompare)
                If rmTag Then .Characters(epos, Len(etag)).Delete
                word = UCase$(Mid(.Value, spos, epos - spos))
                With .Characters(spos, epos - spos)
                    .Insert word
                    .Font.Bold = True
                End With
                spos = InStr(epos, .Value, stag, vbTextCompare)
            Loop
        End With
skipcc:
    Next cc
    
    Set rng = Nothing
    Set cc = Nothing
End Sub

Select all the cells you want to process and run the code - the code runs on all selected cells. It skips blanks if there are any.
I assume the cells contain text and not formulas.
I put in an option to remove the <strong> tags from the text - you have to select Yes in the message box.

 

[JEC]

You might have to enable the regex library in VBA references: Microsoft VBScript Regular Expressions

Sub jec()
 Set Rng = Sheets(1).Cells(1).CurrentRegion
 With CreateObject("VBScript.RegExp")
    For Each st In Rng
       .Global = True
       .Pattern = "(\w+)<"
        Set ar = .Execute(st)
        st.Value = Replace(Replace(st, "<strong>", ""), "</strong>", "")
        For Each it In ar
           st.Characters(InStr(st, Left(it, Len(it) - 1)), Len(it) - 1).Font.Bold = True
        Next
    Next
 End With
End Sub

 

[JEC]

Forgot the uppercase

Sub jec()
 Set Rng = Sheets(1).Cells(1).CurrentRegion
 With CreateObject("VBScript.RegExp")
    For Each st In Rng
       .Global = True
       .Pattern = "(\w+)<"
        Set ar = .Execute(st)
        st.Value = Replace(Replace(st, "<strong>", ""), "</strong>", "")
        For Each it In ar
           jv = Left(it, Len(it) - 1)
           st.Value = Replace(st, jv, UCase(jv))
        Next
        For Each it In ar
           jv = Left(it, Len(it) - 1)
           st.Characters(InStr(1, st, jv, vbTextCompare), Len(it) - 1).Font.Bold = True
        Next
    Next
 End With
End Sub

 

[Peter_SSs]

Forgot the uppercase

You are also relying on the text inside the tags not also occurring outside the tags. For example
Hotdog for the <strong>dog</strong>

it is very heavy and it takes too much time to complete the tas

For me, this tested significantly (5 to 8 times) faster than the other suggestions.

Sub Strong()
  Dim RX As Object, M As Object, d As Object
  Dim a As Variant, itm As Variant, bits As Variant
  Dim i As Long, j As Long, k As Long
  Dim s As String
 
  Application.ScreenUpdating = False
  Set d = CreateObject("Scripting.Dictionary")
  Set RX = CreateObject("VBScript.RegExp")
  RX.Global = True
  RX.Pattern = "(\<strong\>)(.+?)(\<\/strong\>)"
  With Range("A2", Range("A" & Rows.Count).End(xlUp))
    a = .Value2
    For i = 1 To UBound(a)
      s = a(i, 1)
      Set M = RX.Execute(s)
      For Each itm In M
        d(i) = d(i) & " " & itm.firstindex & " " & itm.Length
      Next itm
      s = RX.Replace(s, "$2")
      k = 0
      For Each itm In M
        Mid(s, itm.firstindex - 17 * k + 1, Len(itm.submatches(1))) = UCase(Mid(s, itm.firstindex - 17 * k + 1, Len(itm.submatches(1))))
        k = k + 1
      Next itm
      a(i, 1) = s
    Next i
    .Value = a
    For i = 1 To UBound(a)
      bits = Split(d(i))
      k = 0
      For j = 1 To UBound(bits) Step 2
        .Cells(i).Characters(bits(j) - 17 * k + 1, bits(j + 1) - 17).Font.Bold = True
        k = k + 1
      Next j
    Next i
  End With
  Application.ScreenUpdating = True
End Sub

 

[JEC]

When I put an "Application.Screenupdating = False" on top of my code, it's 0.2 seconds slower at 1000 rows. You won't notice

 

[Akuini]

It isn't clear to me the result you expected:

Hose animals such as the<strong>dog</strong> -> House animals such as the DOG

so you want it bold and UPPERCASE and remove the tag <strong> & </strong>
but in the image you still have <strong> & </strong> as the result
also:

As such, the objective would be to set conditions that would format solely the words inside these remarks, making them bold and UPPERCASE, leaving the rest of the text as it was.

so which one is it?

 

[JEC]

Hose animals such as the<strong>dog</strong> -> House animals such as the DOG

 

[Pquigrafamos]

Try this code:

Option Explicit

Sub FormatStrings()
    Const btag = "strong"
    Const stag = "<" & btag & ">"
    Const etag = "</" & btag & ">"
    Dim rmTag As Boolean
    rmTag = vbYes = MsgBox("Do you want to remove the tags from the text?", vbYesNo + vbDefaultButton1 + vbQuestion, "Remove the tags or keep them?")
   
    Dim rng As Range, cc As Range
    Dim str As String, word As String
    Dim spos As Long, epos As Long
   
    Set rng = Selection
    For Each cc In rng
        With cc
            str = .Value
            If Len(str) = 0 Then GoTo skipcc
            spos = InStr(1, str, stag, vbTextCompare)
            Do While spos > 0
                If rmTag Then .Characters(spos, Len(stag)).Delete Else spos = spos + Len(stag)
                epos = InStr(spos, .Value, etag, vbTextCompare)
                If rmTag Then .Characters(epos, Len(etag)).Delete
                word = UCase$(Mid(.Value, spos, epos - spos))
                With .Characters(spos, epos - spos)
                    .Insert word
                    .Font.Bold = True
                End With
                spos = InStr(epos, .Value, stag, vbTextCompare)
            Loop
        End With
skipcc:
    Next cc
   
    Set rng = Nothing
    Set cc = Nothing
End Sub

Select all the cells you want to process and run the code - the code runs on all selected cells. It skips blanks if there are any.
I assume the cells contain text and not formulas.
I put in an option to remove the <strong> tags from the text - you have to select Yes in the message box.

Thanks a lot, this is absolutely brilliant!! :D
I definitely need to take more time to learn VBA, this is amazing!
It works flawlessly for English text.
If I may ask one more question, for other European languages it would be possible to make the following replacement just for the text within the <strong></strong> tags?

Characters to remove = "ŠŽšžŸÀÁÂÃÄÅÇÈÉÊËÌÍÎÏÐÑÒÓÔÕÖÙÚÛÜÝàáâãäåçèéêëìíîïðñòóôõöùúûüýÿ"
Replacement characters = "SZszYAAAAAACEEEEIIIIDNOOOOOUUUUYaaaaaaceeeeiiiidnooooouuuuyy"

What happens now:
Animais domésticos tais como o <strong>cão</strong> -> Animais domésticos tais como o CÃO

How it should be:
Animais domésticos tais como o <strong>cão</strong> -> Animais domésticos tais como o CAO


I have tried to insert this substitution in your code, but the replacement is happening for all the text contained in the cell, and not just for the Bold and UPPERCASE text.

Best regards!

 

[Pquigrafamos]

Forgot the uppercase

Sub jec()
 Set Rng = Sheets(1).Cells(1).CurrentRegion
 With CreateObject("VBScript.RegExp")
    For Each st In Rng
       .Global = True
       .Pattern = "(\w+)<"
        Set ar = .Execute(st)
        st.Value = Replace(Replace(st, "<strong>", ""), "</strong>", "")
        For Each it In ar
           jv = Left(it, Len(it) - 1)
           st.Value = Replace(st, jv, UCase(jv))
        Next
        For Each it In ar
           jv = Left(it, Len(it) - 1)
           st.Characters(InStr(1, st, jv, vbTextCompare), Len(it) - 1).Font.Bold = True
        Next
    Next
 End With
End Sub

Thanks a lot, this solution is working for English text!