CODEWITHSUNDEEP
htmlexcelvbafont-style
MBF
MBF

Reputation: 366

Excel VBA Macro Replace Html Bold Tag With Bolded Text In Cell

I have the following:

s = 1
f = 1
For i = 1 To UBound(Split(Range("B17").Value, "<b>"))
    s = InStr(f, Range("B17").Value, ("<b>"))
    f = InStr(s, Range("B17").Value, ("</b>"))
    Range("B17").Characters(s, f - s + 1).Font.FontStyle = "Bold"
Next i

This works to loop a cell and make all text between tags bolded. However, this also still leaves behind the tags in the cell.

I need a way to bold between AND remove the tags from a specific cell. I tried to add:

Range("B17").Value = Replace(Range("B17").Value, "<b>", "")
Range("B17").Value = Replace(Range("B17").Value, "</b>", "")

BUT, this not only removed the tags, it also removed the bold font.

Is it possible to do this?

Upvotes: 0

Views: 753

Answers (1)

Variatus
Variatus

Reputation: 14373

This code first notes the position of the tags before removing them. Then, in a separate loop, it applies bold font to the noted text positions.

Private Sub SetCharsBold(Cell As Range)
    ' 086

    Const Tag       As String = "<b>"       ' tag string: start
    Const Tend      As String = "</b>"      ' tag string: end
    Const Pstart    As Integer = 0          ' vector index of Pos()
    Const Pend      As Integer = 1          ' vector index of Pos()
    
    Dim Cv          As String               ' Cell value
    Dim Cnt         As Integer              ' instances of bold expressions
    Dim Pos()       As Variant              ' string positions: 0 = start, 1 = End
    Dim f           As Integer              ' loop counter: Cnt
    
    Cv = Cell.Value
    Cnt = (Len(Cv) - Len(Replace(Cv, Tag, ""))) / 3
    ReDim Pos(Cnt, Pend)
    For f = 1 To Cnt
        Pos(f, Pstart) = InStr(Cv, Tag)
        Cv = Left(Cv, Pos(f, Pstart) - 1) & Mid(Cv, Pos(f, Pstart) + Len(Tag), Len(Cv))
        Pos(f, Pend) = InStr(Cv, Tend) - 1
        Cv = Left(Cv, Pos(f, Pend)) & Mid(Cv, Pos(f, Pend) + Len(Tend) + 1, Len(Cv))
    Next f
    
    With Cell.Offset(18)
        .Font.Bold = False
        .Value = Cv
        For f = 1 To Cnt
            .Characters(Pos(f, Pstart), Pos(f, Pend) - Pos(f, Pstart) + 1).Font.Bold = True
        Next f
    End With
End Sub

I thought it's a bit slow. Therefore I wanted to pause screen updating (Application.ScreenUpdating = False) while it runs but refrained. The reason is that the procedure just formats a single cell. You would probably call it from another procedure that loops through all your cells in a column, feeding each one to the above proc in turn. Use code like SetCharsBold Range("F1"). The screen control should be done in that procedure, delaying the update until its loop has run.

I forgot to remove Cell.Offset(18) from the code and decided to leave it there on second thought. I didn't want the code to over-write the original texts. Perhaps you have a similar need. Please adjust that line to suit.

Upvotes: 1

Related Questions