• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 5365
  • Last Modified:

Macro to Convert Excel Cell to HTML and preserve font formatting.

Is there a macro freely available that can convert a cell in excel to HTML and retain it's font formatting?  I only care about bolds, underlines, colors, and line breaks.  I don't want to export the whole excel document to HTML just specific cells.  I have a program that takes an excel document as it's input but only formats based on HTML and all excel formatting of text is lost.  If I can convert it with a macro I can retain the formatting.


I.E.
Excel Cell:
"
bolded text and underlined text

regular text
"

HTML:
"
<b>bolded text</b> and <i>underlined text</i>r<br>
regular text
"

I could write a macro myself that will search each character for the .FONT format and but figured that something was already written and save some time and effort.
0
PBMax
Asked:
PBMax
  • 2
1 Solution
 
ExcelGuideConsultantCommented:
here you go:
http://charlie.balch.org/hdoc/exceltohtml.html

See first sentence:
"The macros below convert an Excel range to a HTML Table. Most formating, including merged cells, bold, italic and many colors are preserved"

good luck
0
 
PBMaxAuthor Commented:
Thanks Psychotec for the comment but I found that script already.  That script will export the cell with formatting only if the WHOLE cell has the formatting applied.  If you only bold a particular word the code does not work.  
0
 
PBMaxAuthor Commented:
Since I couldn't find a script to do what I required,  I wrote one myself.  Here it is if anyone needs it.  It only converts the Active Cell so you will have to modify it to work for your specific case.


Public Sub Convert()
    Call ConvertToHTMLBold
    Call ConvertToHTMLItalics
    Call ConvertToHTMLUnderline
End Sub


Public Sub ConvertToHTMLBold()

    With ActiveCell
        Dim intStart, intLen As Integer
        intStart = 1
        intLen = 0
        
        If .Font.Bold = True Then
            Debug.Print "Whole cell is Bold: """ & .Value & """" & vbCrLf
            
            'If whole cell is bold then just set the bold tags
            .Characters(intStart, 0).Insert ("<b>")
            .Characters(Len(.Value) + 1, 0).Insert ("</b>")
            
            .Characters(1, 3).Font.Bold = False
            .Characters(1, 3).Font.Italic = False                       'if also italics do not transfer format to html tag
            .Characters(1, 3).Font.Underline = xlUnderlineStyleNone     'if also underlined do not transfer format to html tag
            
            .Characters(Len(.Value) - 3, 4).Font.Bold = False
            .Characters(Len(.Value) - 3, 4).Font.Italic = False                     'if also italics do not transfer format to html tag
            .Characters(Len(.Value) - 3, 4).Font.Underline = xlUnderlineStyleNone   'if also underlined do not transfer format to html tag
        Else
            'Find what part of the cell is bold and set tag to that portion only
            Do While (intStart < Len(.Value))
                Do While (.Characters(intStart, intLen + 1).Font.Bold = True And intLen < Len(.Value))
                    intLen = intLen + 1
                Loop
            
                'Only format cell if a bold characters are found
                If intLen >= 1 Then
                    Debug.Print "Bold Text: " & """" & .Characters(intStart, intLen).Text & """" & vbCrLf & "Start: " & intStart & vbCrLf & "Length: " & intLen & vbCrLf
                    
                    .Characters(intStart, 0).Insert ("<b>")
                    .Characters(intStart, 3).Font.Bold = False
                    .Characters(intStart, 3).Font.Underline = xlUnderlineStyleNone    'if also underlined do not transfer format to html tag
                    .Characters(intStart, 3).Font.Italic = False                      'if also italic do not transfer format to html tag
                    
                    .Characters(intStart + intLen + 3, 0).Insert ("</b>")
                    .Characters(intStart + intLen + 3, 4).Font.Bold = False
                    .Characters(intStart + intLen + 3, 4).Font.Underline = xlUnderlineStyleNone   'if also underlined do not transfer format to html tag
                    .Characters(intStart + intLen + 3, 4).Font.Italic = False                     'if also italic do not transfer format to html tag
                    
                    'Set new starting location; offset by 7 to account for bold html tags in cell
                    intStart = intStart + intLen - 1 + 7
                    intLen = 0
                End If
                
                intStart = intStart + 1
            Loop
        End If
    End With

End Sub


Public Sub ConvertToHTMLItalics()

    With ActiveCell
        Dim intStart, intLen As Integer
        intStart = 1
        intLen = 0
        
        If .Font.Italic = True Then
            Debug.Print "Whole cell is Italic: " & .Value & """" & vbCrLf
            
            'If whole cell is Italic then just set the Italic tags
            .Characters(intStart, 0).Insert ("<i>")
            .Characters(Len(.Value) + 1, 0).Insert ("</i>")
            
            .Characters(1, 3).Font.Italic = False
            .Characters(1, 3).Font.Bold = False                         'if also bold do not transfer format to html tag
            .Characters(1, 3).Font.Underline = xlUnderlineStyleNone     'if also underlined do not transfer format to html tag
            
            .Characters(Len(.Value) - 3, 4).Font.Italic = False
            .Characters(Len(.Value) - 3, 4).Font.Bold = False                       'if also bold do not transfer format to html tag
            .Characters(Len(.Value) - 3, 4).Font.Underline = xlUnderlineStyleNone   'if also underlined do not transfer format to html tag
        Else
            'Find what part of the cell is Italic and set tag to that portion only
            Do While (intStart < Len(.Value))
                Do While (.Characters(intStart, intLen + 1).Font.Italic = True And intLen < Len(.Value))
                    intLen = intLen + 1
                Loop

                'Only format cell if a Italic characters are found
                If intLen >= 1 Then
                    Debug.Print "Italic Text: " & """" & .Characters(intStart, intLen).Text & """" & vbCrLf & "Start: " & intStart & vbCrLf & "Length: " & intLen & vbCrLf
                    
                    .Characters(intStart, 0).Insert ("<i>")
                    .Characters(intStart, 3).Font.Italic = False
                    .Characters(intStart, 3).Font.Bold = False                        'if also bold do not transfer format to html tag
                    .Characters(intStart, 3).Font.Underline = xlUnderlineStyleNone    'if also underlined do not transfer format to html tag
                    
                    .Characters(intStart + intLen + 3, 0).Insert ("</i>")
                    .Characters(intStart + intLen + 3, 4).Font.Italic = False
                    .Characters(intStart + intLen + 3, 4).Font.Bold = False                       'if also bold do not transfer format to html tag
                    .Characters(intStart + intLen + 3, 4).Font.Underline = xlUnderlineStyleNone   'if also underlined do not transfer format to html tag
                    
                    'Set new starting location; offset by 7 to account for bold html tags in cell
                    intStart = intStart + intLen - 1 + 7
                    intLen = 0
                End If
                
                intStart = intStart + 1
            Loop
        End If
    End With

End Sub


Public Sub ConvertToHTMLUnderline()

    With ActiveCell
        Dim intStart, intLen As Integer
        intStart = 1
        intLen = 0

        If .Font.Underline = xlUnderlineStyleSingle Then
            Debug.Print "Whole cell is Underlined: " & .Value & """" & vbCrLf
            
            'If whole cell is underline then just set the underline tags
            .Characters(intStart, 0).Insert ("<u>")
            .Characters(Len(.Value) + 1, 0).Insert ("</u>")
            
            .Characters(1, 3).Font.Underline = xlUnderlineStyleNone
            .Characters(1, 3).Font.Bold = False   'if also bold do not transfer format to html tag
            .Characters(1, 3).Font.Italic = False 'if also italic do not transfer format to html tag
            
            .Characters(Len(.Value) - 3, 4).Font.Underline = xlUnderlineStyleNone
            .Characters(Len(.Value) - 3, 4).Font.Bold = False     'if also bold do not transfer format to html tag
            .Characters(Len(.Value) - 3, 4).Font.Italic = False   'if also italic do not transfer format to html tag
        Else
            'Find what part of the cell is Underline and set tag to that portion only
            Do While (intStart < Len(.Value))
                Do While (.Characters(intStart, intLen + 1).Font.Underline = xlUnderlineStyleSingle And intLen < Len(.Value))
                    intLen = intLen + 1
                Loop

                'Only format cell if a Underline characters are found
                If intLen >= 1 Then
                    Debug.Print "Underlined Text: " & """" & .Characters(intStart, intLen).Text & """" & vbCrLf & "Start: " & intStart & vbCrLf & "Length: " & intLen & vbCrLf
                    
                    .Characters(intStart, 0).Insert ("<u>")
                    .Characters(intStart, 3).Font.Underline = xlUnderlineStyleNone
                    .Characters(intStart, 3).Font.Bold = False    'if also bold do not transfer format to html tag
                    .Characters(intStart, 3).Font.Italic = False  'if also italic do not transfer format to html tag
                    
                    .Characters(intStart + intLen + 3, 0).Insert ("</u>")
                    .Characters(intStart + intLen + 3, 4).Font.Underline = xlUnderlineStyleNone
                    .Characters(intStart + intLen + 3, 4).Font.Bold = False   'if also bold do not transfer format to html tag
                    .Characters(intStart + intLen + 3, 4).Font.Italic = False 'if also italic do not transfer format to html tag
                    
                    'Set new starting location; offset by 7 to account for Underline html tags in cell
                    intStart = intStart + intLen - 1 + 7
                    intLen = 0
                End If
                
                intStart = intStart + 1
            Loop
        End If
    End With

End Sub

Open in new window

1

Featured Post

What does it mean to be "Always On"?

Is your cloud always on? With an Always On cloud you won't have to worry about downtime for maintenance or software application code updates, ensuring that your bottom line isn't affected.

  • 2
Tackle projects and never again get stuck behind a technical roadblock.
Join Now