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

 

[Pquigrafamos]

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

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:

so which one is it?

Yes you are right @Akuini , I forgot to remove the <strong> & </strong> text from the output example in the image. @bobsan42 and @*JEC 's solutions are working though

​

 

[bobsan42]

Yes you are right @Akuini , I forgot to remove the <strong> & </strong> text from the output example in the image. @bobsan42 and @*JEC 's solutions are working though

All solutions work, but the one from Peter_SSs is definetly the fastest.
Even after I modified my code and managed to wedge in between them in the pissing contest it's still 3 to 6 times faster.

 

[Pquigrafamos]

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


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

​

Thank you @Peter_SSs , your solution is working very well

 

[Peter_SSs]

Thank you @Peter_SSs , your solution is working very well

You're welcome.

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"

Try this version. Note that I have used these two full strings but you could save a tiny bit of run-time if you edited out all the lower case characters from both strings (I was just a bit lazy to do that ).
My code below just deals with the 'strong' word after it has been made upper case so the lower case conversions are irrelevant

Sub Strong_v2()
  Dim RX As Object, M As Object, d As Object, dChars 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, tmp As String
 
  Const EuroStr As String = "ŠŽšžŸÀÁÂÃÄÅÇÈÉÊËÌÍÎÏÐÑÒÓÔÕÖÙÚÛÜÝàáâãäåçèéêëìíîïðñòóôõöùúûüýÿ"
  Const ReplEuro As String = "SZszYAAAAAACEEEEIIIIDNOOOOOUUUUYaaaaaaceeeeiiiidnooooouuuuyy"
 
  Application.ScreenUpdating = False
  Set d = CreateObject("Scripting.Dictionary")
  Set dChars = CreateObject("Scripting.Dictionary")
  For i = 1 To Len(EuroStr)
    dChars(Mid(EuroStr, i, 1)) = Mid(ReplEuro, i, 1)
  Next i
  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
        tmp = UCase(Mid(s, itm.firstindex - 17 * k + 1, Len(itm.submatches(1))))
        For j = 1 To Len(tmp)
          If dChars.exists(Mid(tmp, j, 1)) Then Mid(tmp, j, 1) = dChars(Mid(tmp, j, 1))
        Next j
        Mid(s, itm.firstindex - 17 * k + 1, Len(itm.submatches(1))) = tmp
        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

 

[Pquigrafamos]

You're welcome.


Try this version. Note that I have used these two full strings but you could save a tiny bit of run-time if you edited out all the lower case characters from both strings (I was just a bit lazy to do that ).
My code below just deals with the 'strong' word after it has been made upper case so the lower case conversions are irrelevant

Sub Strong_v2()
  Dim RX As Object, M As Object, d As Object, dChars 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, tmp As String
 
  Const EuroStr As String = "ŠŽšžŸÀÁÂÃÄÅÇÈÉÊËÌÍÎÏÐÑÒÓÔÕÖÙÚÛÜÝàáâãäåçèéêëìíîïðñòóôõöùúûüýÿ"
  Const ReplEuro As String = "SZszYAAAAAACEEEEIIIIDNOOOOOUUUUYaaaaaaceeeeiiiidnooooouuuuyy"
 
  Application.ScreenUpdating = False
  Set d = CreateObject("Scripting.Dictionary")
  Set dChars = CreateObject("Scripting.Dictionary")
  For i = 1 To Len(EuroStr)
    dChars(Mid(EuroStr, i, 1)) = Mid(ReplEuro, i, 1)
  Next i
  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
        tmp = UCase(Mid(s, itm.firstindex - 17 * k + 1, Len(itm.submatches(1))))
        For j = 1 To Len(tmp)
          If dChars.exists(Mid(tmp, j, 1)) Then Mid(tmp, j, 1) = dChars(Mid(tmp, j, 1))
        Next j
        Mid(s, itm.firstindex - 17 * k + 1, Len(itm.submatches(1))) = tmp
        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

Hi @Peter_SSs , thanks a lot for the extra help!!
This is interesting, but maybe I am doing something wrong because the Bold UPPERCASE characters continue to appear with their direct equivalents:

The following:

o esquilo come <strong>avelãs</strong>, entre outros

uma porção deste grupo de animais é <strong>Preferível</strong>

animais domésticos tais como o <strong>cão</strong>

animais domésticos tais como o <strong>gato</strong>

Is turning currently into:

o esquilo come AVELÃS, entre outros ->Instead of-> o esquilo come AVELAS, entre outros

uma porção deste grupo de animais é PREFERÍVEL ->Instead of-> uma porção deste grupo de animais é PREFERIVEL

animais domésticos tais como o CÃO ->Instead of-> animais domésticos tais como o CAO

animais domésticos tais como o GATO ->Instead of-> animais domésticos tais como o GATO

I am seeing that in your code the EuroStr is being replaced by the ReplEuro, but this replacement is not happening on my pc. Perhaps there is a problem with my settings?
One poor workaround that I was yesterday trying was a Find and replace function after your original code, referring to the Decimal values instead of the Unicode.
This because only UPPERCASE values will need this replacement, and I was not being able to refer to the text in between the <strong></strong> tags.
Example:

Selection.Replace What:=ChrW(00193), Replacement:=ChrW(00065), LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=True, SearchFormat:=False, _
ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2

But this does not work, because although the characters are replaced correctly, the Bold is removed from the words which contain country-specific characters.

Best regards!

 

[Peter_SSs]

The following:

o esquilo come <strong>avelãs</strong>, entre outros

uma porção deste grupo de animais é <strong>Preferível</strong>

animais domésticos tais como o <strong>cão</strong>

animais domésticos tais como o <strong>gato</strong>

Hmm, I pasted those values into A2:A5 and into B2:B5 and then ran the post #14 code. Here is the result of that:

Looks like what you were asking for?

 

[Pquigrafamos]

Hmm, I pasted those values into A2:A5 and into B2:B5 and then ran the post #14 code. Here is the result of that:

View attachment 46568

Looks like what you were asking for?

So perhaps it has to do with the settings of my computer, in mine the following happens:

I will try to find out what is happening.
Anyways thanks a lot for your big help!!

 

[bobsan42]

So perhaps it has to do with the settings of my computer, in mine the following happens:
View attachment 46580
I will try to find out what is happening.
Anyways thanks a lot for your big help!!

It has to do with Unicode, System settings and VBE not being the perfect tool to deal with the subject.
The code from Peter Strong_v2 worked for me but I had to modify it slightly. Instead of using EuroStr as a constant I pasted all the accented characters as a string in a cell on the sheet - H8 in my case. Then assign the cell's value to EuroStr.
All you have to do is replace one row of his code with other two and adjust the cell reference H8 to whereever you put the characters.
try it like this:

  'Const EuroStr As String = "ŠŽšžŸÀÁÂÃÄÅÇÈÉÊËÌÍÎÏÐÑÒÓÔÕÖÙÚÛÜÝàáâãäåçèéêëìíîïðñòóôõöùúûüýÿ"
  Dim EuroStr As String
  EuroStr = Range("H8").Value

This characters look nothing alike on my VBE screen

 

[Peter_SSs]

It has to do with Unicode, System settings and ...

Are you able to elaborate on the particular system setting(s)?

 

[bobsan42]

Display language for non-unicode programs

I maybe wrong of course, but it is my understanding that while Excel and VBA support Unicode, the VB editor does not (or not too well at least). Me being a non-native English speaker made me deal with many issues on the subject. All I'm saying is one must be quite carefull when dealing with Unicode directrly in VBE. You can see below the change in the pasted characters in a code window and the immediate window. When used like that the sub does not find these characters. For example now I can produce Cyrillic characters in VBE, but others are simply shown as their cyrillic equivalents. However, copying them from the code window back into my post actually returns them as the orginally copied characters, which is a bit odd, I think - it would mean the original character codes are kept/preserved, just the symbols are displayed incorrectly. But then the sub does not replace them as it should, which means VBA reads the characters as displayed in the code window.

However, reading the string from the worksheet works w/o problems.
And you code, Peter, is really quite fast. I plan on spending some time studying, just have to find some