" & strTitle & "

Public Sub RangeToHTM(MyRange, DocDestination, sCaller) ' This macro converts an Excel range to a HTML Table. ' ' Copywrite 1996 - 2011 by Charles Balch, mailto:charlie@balch.edu ' Original Source is at http://balch.org/charlie/hdoc/exceltohtml.html ' MyRange is an Excel range you wish to convert. ' DocDestination is the FileName and Path to send the document to. ' Dim lRGB As Long Dim strTitle, MV, CellV, CellA, BGC, Red, Green, Blue, SFC1, strComment, sTable As String Dim RowStart, Row, RowCount, RowEnd, ColStart, Col, ColCount, ColEnd, Hza, ColSpan, iFreeFile As Integer Dim SameTitle, blnIFrame, blnBoilerPlate As Boolean Dim fso As FileSystemObject Dim fPage As TextStream If InStr(DocDestination, "iFrame_") Then blnIFrame = True 'The result will be optimized to use as an iFrame If InStr(DocDestination, "bp_") Then blnBoilerPlate = True 'The result will be optimized to for inserting into other HTML documents RowStart = Range(MyRange).Row ColStart = Range(MyRange).Column ColCount = Range(MyRange).Columns.Count RowCount = Range(MyRange).Rows.Count RowEnd = RowStart + RowCount - 1 ColEnd = ColStart + ColCount - 1 If Len(Dir(DocDestination)) > 1 Then Kill DocDestination Set fso = New FileSystemObject Set fPage = fso.CreateTextFile(DocDestination, True, True) If blnBoilerPlate Then 'Skip header if boilerplate sTable = "" fPage.WriteLine "" Else fPage.WriteLine "" fPage.WriteLine "" & vbCr fPage.WriteLine "" & vbCr 'fPage.WriteLine "" & vbCr fPage.WriteLine "" & vbCr strTitle = removeHTML(Cells(RowStart, ColStart)) fPage.WriteLine "" & strTitle & "" & vbCr ' Use first cell as title 'Note you may want to use your own style sheets or just remove the sheets entirely If blnIFrame Then fPage.WriteLine "" & vbCr Else fPage.WriteLine "" & vbCr End If fPage.WriteLine "" & vbCr sTable = "

" If blnIFrame Then fPage.WriteLine "" & vbCr sTable = "

" & vbCr Else fPage.WriteLine "" & vbCr End If End If fPage.WriteLine sTable & vbCr While Row < RowCount Row = Row + 1 DoEvents If (Not Range(MyRange).Rows(Row).Hidden) Then MV = "" Col = 0 While Col < ColCount Col = Col + 1 CellV = "" CellA = "" If (Not Range(MyRange).Columns(Col).Hidden) Then 'Define cell color lRGB = Range(MyRange).Cells(Row, Col).Interior.Color Red = Hex(lRGB And 255) If Len(Red) = 1 Then Red = "0" & Red Green = Hex(lRGB \ 256 And 255) If Len(Green) = 1 Then Green = "0" & Green Blue = Hex(lRGB \ 256 ^ 2 And 255) If Len(Blue) = 1 Then Blue = "0" & Blue BGC = " bgcolor=""#" & Red & Green & Blue & """ " If BGC = " bgcolor=""#FFFFFF"" " Then BGC = "" CellV = Range(MyRange).Cells(Row, Col).Text If CellV = "" Then CellV = "
" Else 'Adjust Text If Left(CellV, 1) <> "<" Then CellV = Replace(CellV, Chr(10), (Chr(10) & "
")) 'Add Line Feeds unless HTML 'Proposed by Dan Hinz Not used as it looks like it converts the entire cell to the first hyperlink. ' If Range(MyRange).Cells(Row, Col).Hyperlinks.Count = 1 Then ' CellVH = "" ' CellV = CellVH & Range(MyRange).Cells(Row, Col).Text & "" ' End If 'Add Link to my home page Select Case sCaller Case "AWC" CellV = Replace(CellV, "Charles V. Balch PhD", "Charles V. Balch PhD", 1, -1, vbTextCompare) Case "CVB" CellV = Replace(CellV, "Charles V. Balch", "Charles V. Balch", 1, -1, vbTextCompare) Case "NAU" CellV = Replace(CellV, "Charles V. Balch PhD", "Charles V. Balch PhD", 1, -1, vbTextCompare) End Select 'Define cell alignment Hza = Range(MyRange).Cells(Row, Col).HorizontalAlignment CellA = " align=""left"" " If IsNumeric(CellV) Then CellA = " align=""right"" " If Hza = -4108 Then CellA = " align=""center"" " If Hza = -4131 Then CellA = " align=""left"" " If Hza = -4152 Then CellA = " align=""right"" " If Range(MyRange).Cells(Row, Col).Font.Bold Then CellV = "" & CellV & "" If Range(MyRange).Cells(Row, Col).Font.Italic Then CellV = "" & CellV & "" CellVA = "" vCA = Range(MyRange).Cells(Row, Col).VerticalAlignment If vCA = -4160 Then CellVA = " style=""vertical-align: top"" " If vCA = -4107 Then CellVA = " style=""vertical-align: bottom"" " If vCA = -4108 Then CellVA = " style=""vertical-align: middle"" " 'Define cell font color lRGB = Range(MyRange).Cells(Row, Col).Font.Color SFC1 = "" Red = Hex(lRGB And 255) If Len(Red) = 1 Then Red = "0" & Red Green = Hex(lRGB \ 256 And 255) If Len(Green) = 1 Then Green = "0" & Green Blue = Hex(lRGB \ 256 ^ 2 And 255) If Len(Blue) = 1 Then Blue = "0" & Blue SFC1 = " " If SFC1 = " " Then SFC1 = "" SFC2 = "" Else SFC2 = "" End If End If 'Check for Merged Cells (rows only) If Hza = 7 Or Range(MyRange).Cells(Row, Col).MergeCells Then ColSpan = 0 SameTitle = True While (Range(MyRange).Cells(Row, Col).HorizontalAlignment = 7 Or Range(MyRange).Cells(Row, Col).MergeCells) And SameTitle ' The following code must be changed for versions of Excel earlier than 97 If Not Range(MyRange).Columns(Col).Hidden Then ColSpan = ColSpan + 1 Col = Col + 1 If Len(Range(MyRange).Cells(Row, Col).Text) > 1 Or Not Range(MyRange).Cells(Row, Col).MergeCells Then SameTitle = False Col = Col - 1 End If Wend If ColSpan > ColCount Then ColSpan = ColCount CellA = CellA & " colspan=""" & ColSpan & """ " End If 'Check for Comment (Idea from Michal Matula) sComment = funTestForComment(Range(MyRange).Cells(Row, Col)) If sComment <> "" Then 'The cell does not have a comment sComment = Replace(sComment, Chr(34), Chr(147)) sComment = " title=""" & sComment & """" CellV = "" & CellV & "" End If MV = MV & "" End If Wend fPage.WriteLine "" & vbCr & MV & vbCr & "" & vbCr End If Wend fPage.WriteLine "

" & SFC1 & CellV & SFC2 & "

" & vbCr If Not blnBoilerPlate Then If Not blnIFrame Then fPage.WriteLine "

This table was created using a free Excel macro written by Charles Balch.

" & vbCr fPage.WriteLine "" & vbCr fPage.WriteLine "" & vbCr Else fPage.WriteLine "" End If fPage.Close Set fPage = Nothing Set fso = Nothing End Sub