" & MyTitle & "

Sub RangeToHTM(MyRange, DocDestination) ' This macro will convert an Excel range to a HTML Table. ' ' Copywrite 1996 - 2000 by Charles Balch, mailto:charlie@balch.edu ' Original Source is at http://balch.org/charlie/hdoc ' ' Care Ware! The code is yours to use and adapt for free as long as ' you do something nice for anyone (that includes you). ' Please send me Email describing how you use this code and any ' adjustments that you have made. Redistribute at will. ' Please leave my name and the original source in the comments. ' ' MyRange is an Excel range you wish to convert. ' DocDestination is the FileName and Path to send the document to. ' Application.StatusBar = "Please be patient..." CalcState = Application.Calculation StatusBarState = Application.DisplayStatusBar Application.Calculation = xlManual Calculate 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 Open DocDestination For Output As 1 'create Code Print #1, "" & Chr$(13) Print #1, "" & Chr$(13) 'Establish Font in all areas Print #1, "" & Chr$(13) MyTitle = Cells(RowStart, ColStart) ' Use first cell as title Print #1, "" & MyTitle & "" & Chr$(13) Print #1, "" & Chr$(13) Print #1, "" & Chr$(13) Print #1, "" & Chr$(13) Print #1, "" & Chr$(13) 'Print #1, "" & Chr$(13) While Row < RowCount Row = Row + 1 DoEvents Application.StatusBar = DocDestination & ": " & Str$(Int((Row / RowCount) * 100)) & "% Completed" If (Not Range(MyRange).Rows(Row).Hidden) Then MV = "" Col = 0 While Col < ColCount Col = Col + 1 CellV = "" If (Not Range(MyRange).Columns(Col).Hidden) Then strTemp = Range(MyRange).Cells(Row, Col).Text For intP = 1 To Len(strTemp) strCC = Mid(strTemp, intP, 1) If Asc(strCC) = 10 Then strCC = "
" CellV = CellV & strCC Next intP If CellV = "" Then CellV = "
" HzA = Range(MyRange).Cells(Row, Col).HorizontalAlignment 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 & "" 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 Range(MyRange).Cells(Row, Col).MergeCells = False) Then SameTitle = False: Col = Col - 1 Wend CellA = CellA & " ColSpan=" & ColSpan End If 'find cell interior color CC = Range(MyRange).Cells(Row, Col).Interior.ColorIndex BGC = "" If CC = 1 Then BGC = "#000000" 'black" If CC = 3 Or CC = 22 Then BGC = "#FFD0D0" 'Red" If CC = 4 Or CC = 35 Then BGC = "#CCFFCC" 'green" If CC = 6 Or CC = 19 Then BGC = "#FFFFCC" 'yellow" If CC = 8 Or CC = 41 Or CC = 34 Or CC = 20 Then BGC = "#CCFFFF" 'blue If CC = 9 Then BGC = "#8A0045" 'burgandy If CC = 15 Or CC = 40 Then BGC = "#DFDED0" 'grey" If CC = 39 Or CC = 24 Or CC = 39 Then BGC = "#FFCCFF" 'Purple If Len(BGC) > 2 Then BGC = " bgcolor=" & Chr(34) & BGC & Chr(34) 'find cell font color FC = Range(MyRange).Cells(Row, Col).Font.ColorIndex SFC1 = "" SFC2 = "" If FC = 3 Then SFC1 = "" ElseIf FC = 2 Then SFC1 = "" End If If Len(SFC1) > 2 Then SFC2 = "" 'Replace chr(13) with
'Range(MyRange).Cells(Row, Col).Replace MV = MV & "" & SFC1 & CellV & SFC2 & "" End If Wend Print #1, "" & MV & "" & Chr$(13) End If Wend Print #1, "

" & Chr$(13) Print #1, "

" & Chr$(13) Print #1, "This table was created by a free Excel macro written by Charles Balch.
" & Chr$(13) Print #1, "Here's the code. It is care ware - it's yours for free if do something nice for anyone (anyone includes you)." Print #1, "" & Chr$(13) Close DoEvents Application.Calculation = CalcState Application.StatusBar = "" Application.DisplayStatusBar = StatusBarState End Sub