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

Pquigrafamos

New Member
Joined
Sep 8, 2021
Messages
8
Office Version
  1. 365
  2. 2019
  3. 2016
Platform
  1. Windows
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 :)
 

Attachments

  • Excel example1.PNG
    Excel example1.PNG
    10.5 KB · Views: 13

Excel Facts

Best way to learn Power Query?
Read M is for (Data) Monkey book by Ken Puls and Miguel Escobar. It is the complete guide to Power Query.

bobsan42

Well-known Member
Joined
Jul 14, 2010
Messages
1,838
Office Version
  1. 365
  2. 2019
  3. 2016
  4. 2013
Platform
  1. Windows
Try this code:
VBA 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.
 
Solution

JEC

Active Member
Joined
Aug 21, 2021
Messages
322
Office Version
  1. 365
Platform
  1. Windows
You might have to enable the regex library in VBA references: Microsoft VBScript Regular Expressions

VBA Code:
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

Active Member
Joined
Aug 21, 2021
Messages
322
Office Version
  1. 365
Platform
  1. Windows
Forgot the uppercase

VBA Code:
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

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
50,644
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

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.

VBA Code:
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

Active Member
Joined
Aug 21, 2021
Messages
322
Office Version
  1. 365
Platform
  1. Windows
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

Well-known Member
Joined
Feb 1, 2016
Messages
3,308
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

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

Active Member
Joined
Aug 21, 2021
Messages
322
Office Version
  1. 365
Platform
  1. Windows
Hose animals such as the<strong>dog</strong> -> House animals such as the DOG
 

Pquigrafamos

New Member
Joined
Sep 8, 2021
Messages
8
Office Version
  1. 365
  2. 2019
  3. 2016
Platform
  1. Windows
Try this code:
VBA 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

New Member
Joined
Sep 8, 2021
Messages
8
Office Version
  1. 365
  2. 2019
  3. 2016
Platform
  1. Windows
Forgot the uppercase

VBA Code:
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! :)
 

Forum statistics

Threads
1,141,584
Messages
5,707,209
Members
421,498
Latest member
matinebi

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top