Home > Publications & Training > Case Studies > Worksheet to HTML
Google
Web This Site

Showing an Excel worksheet in HTML (i.e., on a web page)

This was inspired by a discussion on the website www.dailydoseofexcel.com.

I had asked Dick Kusleika to share the data in his posts so that one could copy+paste it into Excel.  He responded with a solution in Make a Simple HTML Table from a Range (http://www.dailydoseofexcel.com/archives/2010/09/23/make-a-simple-html-table-from-a-range/).  This more than adequately addressed my requirments.

Subsequently, Michael posted an enhanced version that retained some of the cell formatting in TableMaker 2.0 (http://www.dailydoseofexcel.com/archives/2010/10/08/tablemaker-20/)  In the resulting discussion, I suggested that we have Excel do the hard work of sharing the format by saving the worksheet in SpreadsheetML (an Excel 2003 format) and extracting the resulting HTML.  Rob van Gelder suggested the code in the Microsoft support page http://support.microsoft.com/kb/274326

After researching that article I modified some of the article’s code and added my own to develop the solution below.  In the resulting code, running CellsToHTML generates the HTML corresponding to the current selection – which must consist of a single region.  The HTML code is in the clipboard ready for pasting as required.

It turns out that the Excel generated HTML does not include row or column headers.  Consequently, the code in CellsToHTML adds row and column headers using the current referencing system (A1 or R1C1).  The result includes 2 tables: the first contains the cell values and the 2nd the associated formulas.

Figure 1 – The result of running CellsToHTML is 2 tables: the 1st showing the cell values, the 2nd the formulas

Since the process uses the Excel-generated HTML, we get the strengths and limitations of whatever Excel does.  The one exception is that the code modifies the CSS style for the HTML TD tag to display the table contents using as much of the available width as possible and it adds borders to the tables to mimic Excel gridlines.

Differences in how browsers display the result

Unfortunately, even after all these years of browser development and talk of adherence to standards, the result of the code remains browser dependent.  Internet Explorer 8 was the only browser that correctly displayed the entire test formatting.  The test included various cell formats including font color, fill color, and cell borders; different fonts (including Symbol and Wingding); different format of individual characters in a cell; characters outside the standard ASCII range; conditional formatting; formulas including array formulas; hyperlinks (including those created through the HYPERLINK formula).   Firefox rendered everything but the fonts Symbol and Wingdings correctly.  Google Chrome showed everything but the border around cell B1 correctly.  Safari failed to show the border around B1 and it also failed to show the Symbol and Wingdings fonts correctly.

 

Figure 2 – The original Excel worksheet

 

Figure 3 – Internet Explorer 8 faithfully renders the Excel worksheet

 

Figure 4 – Firefox 3.6 fails to show the Symbol and Wingdings fonts correctly

 

Figure 5 – Google Chrome 7.0 fails to show the border around B1 correctly

 

Figure 6 – Safari 4.0 fails to show the border around B1 or to render the Symbol and Wingdings fonts correctly

 

How to use

The code below goes in a standard module.  Once added select a single contiguous worksheet range and run the CellsToHTML subroutine.  The required HTML code will be in the clipboard.  Switch to the program window where you want the HTML code and paste.

Option Explicit

 

'The starting point for the code in this module was _

 http://support.microsoft.com/kb/274326 _

 though it has been extensively modified to suit my requirements _

 _

 The code has *not* been converted for use on a 64bit system.

 

Private Declare Function CloseClipboard Lib "user32" () As Long

Private Declare Function OpenClipboard Lib "user32" (ByVal hWnd As Long) _

   As Long

Private Declare Function GlobalAlloc Lib "kernel32" ( _

   ByVal wFlags As Long, ByVal dwBytes As Long) As Long

Private Declare Function SetClipboardData Lib "user32" ( _

   ByVal wFormat As Long, ByVal hMem As Long) As Long

Private Declare Function EmptyClipboard Lib "user32" () As Long

Private Declare Function RegisterClipboardFormat Lib "user32" Alias _

   "RegisterClipboardFormatA" (ByVal lpString As String) As Long

Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) _

   As Long

Private Declare Function GlobalUnlock Lib "kernel32" ( _

   ByVal hMem As Long) As Long

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _

   pDest As Any, pSource As Any, ByVal cbLength As Long)

Private Declare Function GetClipboardData Lib "user32" ( _

   ByVal wFormat As Long) As Long

Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" ( _

   ByVal lpData As Long) As Long

 

 

                 

Private m_cfHTMLClipFormat As Long

 

Function RegisterCF() As Long   'untouched from the MSKB article

 

 

   'Register the HTML clipboard format

   If (m_cfHTMLClipFormat = 0) Then

      m_cfHTMLClipFormat = RegisterClipboardFormat("HTML Format")

   End If

   RegisterCF = m_cfHTMLClipFormat

  

End Function

 

Public Function GetHTMLClipboard(ByRef StyleHTML As String, _

        ByRef TableHTML As String) As Boolean

 

    Dim sData As String

  

    If RegisterCF() = 0 Then Exit Function

   

    If CBool(OpenClipboard(0)) Then

  

        Dim hMemHandle As Long, lpData As Long

        Dim nClipSize As Long

       

        'GlobalUnlock hMemHandle

        'removed by TM:don't understand the logic of unlocking _

         something that is not yet locked

 

        hMemHandle = GetClipboardData(m_cfHTMLClipFormat)

     

        If CBool(hMemHandle) Then

              

            lpData = GlobalLock(hMemHandle)

            If lpData <> 0 Then

                nClipSize = lstrlen(lpData)

                sData = String(nClipSize + 10, 0)

               

   

                Call CopyMemory(ByVal sData, ByVal lpData, nClipSize)

               

                'The code below added by TM; replaces the code from the _

                 MSKB article

                Dim StyleStart As Long, StyleEnd As Long

                StyleStart = InStr(1, sData, "<style>", vbTextCompare)

                StyleEnd = _

                    InStr(StyleStart, sData, "</style>", vbTextCompare)

               

                Dim TableStart As Long, TableEnd As Long

                TableStart = InStr(1, sData, "<table ", vbTextCompare)

                If TableStart = 0 Then _

                    TableStart = InStr(1, sData, "<table>", vbTextCompare)

                TableEnd = _

                    InStr(TableStart, sData, "</table>", vbTextCompare)

               

                StyleHTML = Mid(sData, StyleStart, _

                    StyleEnd + Len("</style>") - StyleStart)

                TableHTML = Mid(sData, TableStart, _

                    TableEnd + Len("</table>") - TableStart)

               

                End If  'lpData <> 0

     

            GlobalUnlock hMemHandle 'Added by TM

            End If  'CBool(hMemHandle)

 

        Call CloseClipboard

        End If  'CBool(OpenClipboard(0))

    End Function

   

    Function getColHdrsHTML(FirstCell As Range, LastCell As Range) As String

        Dim Rslt As String, I As Long

        Rslt = vbNewLine & "<tr><th>&nbsp;</th>"

        For I = FirstCell.Column To LastCell.Column

            If Application.ReferenceStyle = xlR1C1 Then

                Rslt = Rslt & "<th>" & I & "</th>"

            Else

                Rslt = Rslt & "<th>" _

                    & Replace( _

                        Application.ConvertFormula("R1C" & I, xlR1C1, _

                            xlA1, xlRelative), _

                        "1", "") _

                    & "</th>"

                End If

            Next I

        Rslt = Rslt & "</tr>" & vbNewLine

        getColHdrsHTML = Rslt

        End Function

    Function addRowHdrsHTML(ByVal sData As String, FirstCell As Range, _

            LastCell As Range) As String

        Dim Rslt As String, I As Long

        For I = FirstCell.Row To LastCell.Row

            Dim TRPos As Long

            TRPos = InStr(1, sData, "<tr ", vbTextCompare)

            If TRPos = 0 Then TRPos = InStr(1, sData, "<tr>", vbTextCompare)

            Dim TDPos As Long

            TDPos = InStr(TRPos, sData, "<td ", vbTextCompare)

            If TDPos = 0 Then _

                TDPos = InStr(TRPos, sData, "<td>", vbTextCompare)

            Rslt = Rslt & Left(sData, TDPos - 1) _

                & "<td class=""RowN"">" & I & "</td>"

            sData = Mid(sData, TDPos)

            Next I

        Rslt = Rslt & sData

        addRowHdrsHTML = Rslt

        End Function

Function addRowAndColHdr(ByVal sData As String, FirstCell As Range, _

        LastCell As Range)

    'To add the column headers we add a row to the table before the _

     current first row with the appropriate column header. _

     To add row numbers we have to add a cell at the start of every _

     existing row with the appropriate row number

    Dim ColHdrsHTML As String

    ColHdrsHTML = getColHdrsHTML(FirstCell, LastCell)

    

    sData = addRowHdrsHTML(sData, FirstCell, LastCell)

   

    Dim TRPos As Long

    TRPos = InStr(1, sData, "<tr ", vbTextCompare)

    If TRPos = 0 Then TRPos = InStr(1, sData, "<tr>", vbTextCompare)

    addRowAndColHdr = Left(sData, TRPos - 1) _

        & ColHdrsHTML & Mid(sData, TRPos)

    End Function

 

Function addBordersAndvAlignStyle() As String

    addBordersAndvAlignStyle = vbNewLine _

        & "<style>" & vbNewLine _

        & "    td{border:1px solid gray}" & vbNewLine _

        & "    .RowN{vertical-align:middle;font-weight:bold}" & vbNewLine _

        & "    </style>" & vbNewLine

    End Function

Function removeColTag(ByVal FormulaTableHTML As String) As String

    Dim ColPos As Long, TRPos As Long

    ColPos = InStr(1, FormulaTableHTML, "<col ", vbTextCompare)

    If ColPos <> 0 Then

        TRPos = InStr(ColPos, FormulaTableHTML, "<tr ", vbTextCompare)

        If TRPos = 0 Then _

            TRPos = InStr(ColPos, FormulaTableHTML, "<tr>", vbTextCompare)

        removeColTag = Left(FormulaTableHTML, ColPos - 1) _

            & Mid(FormulaTableHTML, TRPos)

        End If

    End Function

Function addMetaTag() As String

    addMetaTag = "<meta http-equiv=""Content-Type"" content=""text/html; " _

            & "charset=utf-8"">" _

        & vbNewLine

    End Function

Function addValuesHdr() As String

    addValuesHdr = _

        "<div id=""TM_Excel_Values"" " _

            & "style=""margin-bottom:10px"">" & vbNewLine _

        & "<p>Values:</p>" & vbNewLine

    End Function

Function addFormulasHdr() As String

    addFormulasHdr = _

        "<div id=""TM_Excel_Formulas"">" & vbNewLine _

        & "<p>Formulas:</p>" & vbNewLine

    End Function

Sub CellsToHTML()

    If Not TypeOf Selection Is Range Then _

        MsgBox "Please select a single contiguous range first": Exit Sub

    If Selection.Areas.Count > 1 Then _

        MsgBox "Please select a single contiguous range first": Exit Sub

   

    Dim SrcRng As Range: Set SrcRng = Selection

   

    Dim FirstCell As Range, LastCell As Range

    With SrcRng

    Set FirstCell = .Cells(1)

    Set LastCell = .Cells(.Rows.Count, .Columns.Count)

        End With

   

    Dim OldDisplayFormulas As Boolean

    OldDisplayFormulas = ActiveWindow.DisplayFormulas

   

    ActiveWindow.DisplayFormulas = False

    SrcRng.Copy: DoEvents

   

    Dim StyleHTML As String, TableHTML As String

    GetHTMLClipboard StyleHTML, TableHTML

    StyleHTML = StyleHTML & addBordersAndvAlignStyle()

   

    Dim Rslt As String

    Rslt = addMetaTag() _

        & StyleHTML & vbNewLine _

        & addValuesHdr() _

        & addRowAndColHdr(TableHTML, FirstCell, LastCell) _

        & "</div>" & vbNewLine

        'should actually have the getHTMLClipboard return the _

         actual 'content-type' tag

 

    ActiveWindow.DisplayFormulas = True

    SrcRng.Copy: DoEvents

   

    Dim FormulaStyleHTML As String, FormulaTableHTML As String

    GetHTMLClipboard FormulaStyleHTML, FormulaTableHTML

   

    ActiveWindow.DisplayFormulas = OldDisplayFormulas

    Application.CutCopyMode = False

   

    FormulaTableHTML = removeColTag(FormulaTableHTML)

   

    Rslt = Rslt _

        & addFormulasHdr() _

        & addRowAndColHdr(FormulaTableHTML, FirstCell, LastCell) _

        & "</div>" & vbNewLine

   

    'Debug.Print Rslt

    With New DataObject

    .SetText Rslt

    .PutInClipboard

        End With

    End Sub