Generate HTML From Excel
I often find Microsoft Excel a good tool for generating tables of genealogical and other material. It's possible to actually write a string concatenation formula in Excel that can create HTML <tr> and <td> entries. If you have three cells, A1, B1 and C1, for example, you can create a formula in cell D1 as follows:
="<tr><td>" & a1 & "</td><td>" & b1 & "</td><td>" & c1 & "</td></tr>"
If you have Apple, Banana and Orange in the first 3 cells of row 1, then the result will be as follows:
<tr><td>Apple</td><td>Banana</td><td>Orange</td></tr>
If you take the above result and place it within opening and closing HTML table tags, you'll see the following:
This approach is fine for simple tables, but I make use of a couple of simple cell formatting features, namely cell content alignment and cell content bolding. I also may have several consecutive empty cells and would prefer to consolidate the consecutive cells into a single HTML td tag with a colspan attribute. To do this requires considerably more programming.
Here's what I've developed thus far using Excel VBA code (there may be a more efficient approach to programming this, but now that it's working, that's sufficient for me):
Option Explicit
Public Const MAX_ROW = 65535
Public Const MAX_COL = 255
Public Const WHICH_WORKSHEET = 2
Public Const BOLD_OPEN = ""
Public Const BOLD_CLOSED = ""
Public Function GenerateHTMLTable()
Dim iLastNonBlankRow As Integer
Dim iLastNonBlankCol As Integer
Dim sHTML As String
Dim i As Integer
Dim j As Integer
Dim oSheet As Worksheet
Dim iFileHandle As Integer
Dim sFileName As String
Dim iBlankConsecutiveCols As Integer
' HTML Output:
iFileHandle = FreeFile
sFileName = "E:Table.html"
Open sFileName For Output As iFileHandle
iLastNonBlankRow = 0
iLastNonBlankCol = 0
Set oSheet = Worksheets(WHICH_WORKSHEET)
If (FindLastCell(iLastNonBlankRow, iLastNonBlankCol)) Then
sHTML = "
" & vbCrLf
Dim aCellText(MAX_COL) As String
Dim aCellFormatBold(MAX_COL) As String
Dim aCellAlignRight(MAX_COL) As String
' Loop through all populated spreadsheet rows:
For i = 1 To iLastNonBlankRow
' Single indent:
sHTML = sHTML & vbTab & "
" & vbCrLf
' Loop through all of the current row's cells:
For j = 1 To iLastNonBlankCol
' Capture cell information:
aCellText(j) = Trim(oSheet.Cells(i, j).Text)
aCellFormatBold(j) = oSheet.Cells(i, j).Font.Bold
aCellAlignRight(j) = oSheet.Cells(i, j).HorizontalAlignment
' DEBUG
If InStr(aCellText(j), "Total in 2010") > 0 Then
Stop
End If
' Blank cell
If Len(aCellText(j)) = 0 Then
' If first cell of the row:
If j = 1 Then
' sHTML = sHTML & vbCrLf
iBlankConsecutiveCols = 1
Else
' Was previous column also blank?
If Len(aCellText(j - 1)) = 0 Then
' Yes:
iBlankConsecutiveCols = iBlankConsecutiveCols + 1
Else
' No
iBlankConsecutiveCols = 1
End If
End If
Else
' If first/left-most cell of the row:
If j = 1 Then
iBlankConsecutiveCols = 0
' Double indent:
sHTML = sHTML & vbTab & vbTab
sHTML = sHTML & ReturnLeadingTD(aCellText(j), aCellAlignRight(j), iBlankConsecutiveCols)
sHTML = sHTML & ReturnCellContents(aCellText(j), aCellFormatBold(j)) & "
" & vbCrLf
Else
' Double indent:
If Len(aCellText(j - 1)) = 0 Then
iBlankConsecutiveCols = iBlankConsecutiveCols + 1
End If
sHTML = sHTML & vbTab & vbTab
sHTML = sHTML & ReturnLeadingTD(aCellText(j), aCellAlignRight(j), iBlankConsecutiveCols)
sHTML = sHTML & ReturnCellContents(aCellText(j), aCellFormatBold(j)) & "
" & vbCrLf
iBlankConsecutiveCols = 0
End If
End If
Next j
' Check whether all columns were blank:
If iBlankConsecutiveCols = iLastNonBlankCol Then
sHTML = sHTML & vbTab & vbTab & "
| |
" & vbCrLf
Else
' Is there a need to flush content when the last cell was blank?
If iBlankConsecutiveCols > 0 Then
sHTML = sHTML & vbTab & vbTab & "
|
" & vbCrLf
End If
End If
sHTML = sHTML & vbTab & "
" & vbCrLf
Next i
sHTML = sHTML & "
" & vbCrLf
Print #iFileHandle, sHTML
End If
Close iFileHandle
End Function
Private Function ReturnCellContents(sCellText, bIsBold)
Dim sRet As String
If bIsBold And Len(sCellText) > 0 Then
sRet = BOLD_OPEN & sCellText & BOLD_CLOSED
Else
If Len(sCellText) > 0 Then
sRet = sCellText
Else
sRet = " "
End If
End If
ReturnCellContents = sRet
End Function
Private Function ReturnLeadingTD(sCellText, bIsAlignRight, iBlankConsecutiveCols)
Dim sRet As String
' Options:
' 1.
' 2.
|
' 3.
|
' 4.
|
' This coding approach will break down if more conditions are introduced
' There's still a bug - this happens when there are several leading non-blank columns...
If Len(sCellText) = 0 Then
sRet = "
1 Then
sRet = sRet & " colspan='" & CStr(iBlankConsecutiveCols) & "'>"
Else
sRet = sRet & ">"
End If
Else
If bIsAlignRight Then
sRet = "
1 Then
sRet = sRet & " colspan='" & CStr(iBlankConsecutiveCols) & "'>"
Else
sRet = sRet & ">"
End If
Else
sRet = "
1 Then
sRet = sRet & " colspan='" & CStr(iBlankConsecutiveCols) & "'>"
Else
sRet = sRet & ">"
End If
End If
End If
ReturnLeadingTD = sRet
End Function
Private Function FindLastCell(ByRef iLastNonBlankRow As Integer, ByRef iLastNonBlankCol As Integer)
' Don't rely on what Excel tells us. Use an alternative approach to finding
' the last cell of a spreadsheet.
' We will use Excel 2003 settings for the maximum row and column.
' If we have this many rows following the last row that contained a non-blank cell, we can stop.
Const MAX_ROW_GAP = 50
Dim i As Long
Dim j As Integer
Dim oSheet As Worksheet
On Error GoTo FindLastCell_Error
Set oSheet = Worksheets(WHICH_WORKSHEET)
For i = 1 To MAX_ROW
For j = 1 To MAX_COL
If Len(Trim(oSheet.Cells(i, j))) > 0 Then
iLastNonBlankRow = i
iLastNonBlankCol = j
End If
Next j
' Check how many rows since the last non-blank cell was found:
If (i - iLastNonBlankRow) > MAX_ROW_GAP Then
Exit For
End If
Next i
FindLastCell = True
Exit Function
FindLastCell_Error:
FindLastCell = False
End Function
Last updated April 12, 2010 8:33:04 AM
| | 
Thailand