htmlexcelvbafont-style

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?


Solution

  • 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.