HTML formatting in a cell

[Chet Cromer]

I have a query that I am getting into Excel as a QueryTable and one of the
fields contains HTML codes (this same query is also used to generate a web
page). The contents of this field are something like this:

PW,PL,PS,<b>Leather</b>,<b>Sun Roof</b>,Automatic

As you can see the query is designed to bold some of the options for
vehicles. THis works great on a webpage but not at all in a standard Excel
Querytable, which of course doesn't translate the < > blocks into bold.
There's no way to get Excel to recognize this type of formatting, is there?
I'm thinking of using some loops and the Instr function to isolate blocks of
bold and then using the .characters() collection to bold them, but that's
going to be a chore...and I'm always looking for an easier way.

Any ideas? Thanks in advance.

Chet

 

[Chet Cromer]

Well, here's how I did it, in case anyone ever finds this handy... I
actually got it so it could handle multiple tags; this code does <b></b> and
<i></i>.

'cel is a reference to a cell in the range (I loop through all of the cells
to fix)
'Bold
spos = InStr(1, cel.Value, "<b>")
Do Until spos = 0
epos = InStr(spos + 1, cel.Value, "</b>")
If epos = 0 Then epos = Len(cel.Value) + 1
sChar = spos + 3
eChar = epos - 1
With cel.Characters(sChar, epos - sChar)
.Font.Bold = True
End With
cel.Characters(spos, 3).Delete
cel.Characters(epos - 3, 4).Delete
spos = InStr(1, cel.Value, "<b>")
Loop

'Italic
spos = InStr(1, cel.Value, "<i>")
Do Until spos = 0
epos = InStr(spos + 1, cel.Value, "</i>")
If epos = 0 Then epos = Len(cel.Value) + 1
sChar = spos + 3
eChar = epos - 1
With cel.Characters(sChar, epos - sChar)
.Font.Italic = True
End With
cel.Characters(spos, 3).Delete
cel.Characters(epos - 3, 4).Delete
spos = InStr(1, cel.Value, "<i>")
Loop

 

[Chet Cromer]

Better yet, a subroutine to do the work:

Private Sub FixHTMLCodes(rng As Range)
'Fix Italics and bold
Dim spos As Integer
Dim epos As Integer
Dim cel As Range
Dim y As Long
Dim sChar As Integer
Dim eChar As Integer
Dim strNew As String

For Each cel In rng.Cells
'Bold
spos = InStr(1, cel.Value, "<b>")
Do Until spos = 0
epos = InStr(spos + 1, cel.Value, "</b>")
If epos = 0 Then epos = Len(cel.Value) + 1
sChar = spos + 3
eChar = epos - 1
With cel.Characters(sChar, epos - sChar)
.Font.Bold = True
End With
cel.Characters(spos, 3).Delete
cel.Characters(epos - 3, 4).Delete
spos = InStr(1, cel.Value, "<b>")
Loop
'Italic
spos = InStr(1, cel.Value, "<i>")
Do Until spos = 0
epos = InStr(spos + 1, cel.Value, "</i>")
If epos = 0 Then epos = Len(cel.Value) + 1
sChar = spos + 3
eChar = epos - 1
With cel.Characters(sChar, epos - sChar)
.Font.Italic = True
End With
cel.Characters(spos, 3).Delete
cel.Characters(epos - 3, 4).Delete
spos = InStr(1, cel.Value, "<i>")
Loop
Next cel

End Sub