Convert Excel to HTML

Function fCreateHTMLTable(rngData As Range, _
                          blnUseHeaderTags As Boolean) As String
  '===================================================================
  '=   Procedure: fCreateHTMLTable                                   =
  '=        Type: Private Function                                   =
  '=                                                                 =
  '=     Purpose: Creates a 'clean' HTML table (ie. no unwanted      =
  '=              formatting tags) from an Excel range. Understands  =
  '=              merged cells.                                      =
  '=  Parameters: rngData - Range - The range to be converted to     =
  '=              HTML. blnUseHeaderTags - Boolean - True if column  =
  '=              heads are to use <TH> rather than <TD> tags.       =
  '=     Returns: String - The HTML string surrounded by <TABLE>     =
  '=              tags.                                              =
  '=                                                                 =
  '= Version:  Date:     Developer:      Action:                     =
  '=---------|---------|---------------|-----------------------------=
  '=  1.0.0  |15-Nov-99|   Rob Bruce   | Created                     =
  '===================================================================

  '===============================================================
  'HTML Tags
  'Table
  Const TABLE_BEGIN As String = "<TABLE>"
  Const TABLE_END As String = "</TABLE>"
 
  'Row
  'light blue
  Const TABLE_ROW_FIELDS As String = "<TR bgcolor=#DCDCFF>"
  'light yellow
  Const TABLE_ROW_ODDS As String = "<TR bgcolor=#FFF66>"
  'no background colour
  Const TABLE_ROW As String = "<TR>"
  Const TABLE_ROW_END As String = "</TR>"
 
  'Cells
  Const TABLE_HEADER_BEGIN As String = "<TH"
  Const TABLE_HEADER_END As String = "</TH>"
  Const TABLE_CELL_BEGIN As String = "<TD"
  Const TABLE_CELL_END As String = "</TD>"
 
  'Attributes
  Const TABLE_CELL_MERGEROWS As String = " ROWSPAN = """
  Const TABLE_CELL_MERGECOLS As String = " COLSPAN = """
 
  'Misc
  Const DOUBLE_QUOTE As String = """"
  Const TAG_CLOSE As String = ">"
  Const COMMENT_START As String = "<!--Exported From Excel: "
  Const COMMENT_END As String = "-->"
  '===============================================================

  Dim intColCount As Integer
  Dim intRowCount As Integer
  Dim intColCounter As Integer
  Dim intRowCounter As Integer
 
  Dim intMergeRowsCount As Integer
  Dim intMergeColsCount As Integer
 
  Dim rngCell As Range
  Dim blnCommitCell As Boolean
 
  Dim strHTML As String
  Dim strAttributes As String
 
  'Initial table tag...
  strHTML = TABLE_BEGIN
  'Comment - delete this line or comment it out
  'if you don't want the HTML comment at the head
  'of your table...
  strHTML = strHTML & vbCrLf & COMMENT_START & _
            rngData.Address(external:=True) & _
            COMMENT_END
 
  With rngData
 
    'Discover dimensions of the data we
    'will be dealing with...
    intColCount = .Columns.Count
    intRowCount = .Rows.Count
 
    'Loop down the table's rows
    For intRowCounter = 1 To intRowCount
 
      'Make the HTML a little friendlier
      If intRowCounter = 1 Then
        If blnUseHeaderTags Then
          strHTML = strHTML & vbCrLf & TABLE_ROW_FIELDS
        Else
          strHTML = strHTML & vbCrLf & TABLE_ROW_ODDS
        End If
      Else
        If Not intRowCounter Mod 2 = 0 Then
          strHTML = strHTML & vbCrLf & TABLE_ROW_ODDS
        Else
          strHTML = strHTML & vbCrLf & TABLE_ROW
        End If
      End If
 
      'Loop accross columns...
      For intColCounter = 1 To intColCount
 
        'Mark the cell under current scrutiny by setting
        'an object variable...
        Set rngCell = .Cells(intRowCounter, intColCounter)
 
        '(Re-) initialise variable that will hold
        'the cell's internal attributes...
        strAttributes = ""
 
        '(Re-) initialise variable that will tell us
        'whether this cell will be written to the table
        '(it will not if it is part of a merged range
        'and is not that range's first cell).
        blnCommitCell = True
 
        'Is the cell merged?..
        If Not rngCell.MergeArea.Address = _
           rngCell.Address Then
 
          'Is the cell the first cell in the merged range?
          '(we're only interested in it if it is)
          If rngCell.Address = rngCell.MergeArea. _
             Cells(1).Address Then
 
            'How many columns in the merged range?..
            intMergeColsCount = rngCell.MergeArea. _
                                Columns.Count
 
            'If there are more than one we need to
            'register this in the Attributes string...
            If Not intMergeColsCount = 1 Then
              strAttributes = TABLE_CELL_MERGECOLS & _
                              intMergeColsCount & DOUBLE_QUOTE
            End If
 
            'Do the same sort of thing for rows in
            'the merged range...
            intMergeRowsCount = rngCell.MergeArea _
                                .Rows.Count
 
            If Not intMergeRowsCount = 1 Then
              strAttributes = strAttributes & _
                              TABLE_CELL_MERGEROWS & _
                              intMergeRowsCount & DOUBLE_QUOTE
            End If
 
          Else
            'Otherwise we don't want to do anything
            'with this cell - it is irrelevant to
            'HTML: Only the first (upper left) cell
            'of an HTML merged range is actually
            'coded into the table...
            blnCommitCell = False
          End If
 
        End If
 
        'OK, so now we need to construct the actual
        'HTML tag for the cell - if the cell is to
        'be coded, of course...
        If blnCommitCell Then
          'Use <TH> table header tags for the top
          'row of the table...
          If intRowCounter = 1 And blnUseHeaderTags Then
            strHTML = strHTML & TABLE_HEADER_BEGIN & _
                      strAttributes & TAG_CLOSE
          Else
            'Otherwise use regular <TD> tags...
            strHTML = strHTML & TABLE_CELL_BEGIN & _
                      strAttributes & TAG_CLOSE
 
          End If
 
          'Now we can enter the cell's actual value.
          'We'll use the Text property of the cell
          'so that the actual display of the cell is
          'coded into the HTML table...
          strHTML = strHTML & rngCell.Text
 
          'Close off the tag by inserting the
          'appropriate </TH> or </TD> tag end.
          If intRowCounter = 1 And blnUseHeaderTags Then
            strHTML = strHTML & TABLE_HEADER_END
          Else
            strHTML = strHTML & TABLE_CELL_END
          End If
        End If
 
      Next intColCounter
 
      'Close off the row...
      strHTML = strHTML & TABLE_ROW_END
    Next intRowCounter
  End With
 
  'Finally, close off the table...
  strHTML = strHTML & vbCrLf & TABLE_END
 
  'Return the HTML string...
  fCreateHTMLTable = strHTML
 
End Function