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