Sub RangeToHTM(MyRange, DocDestination)
' This macro will convert an Excel range to a HTML Table.
' Most formating is preserved. Font size, row & column hight
' are ignored. I may add those at a later date.
'
' Hacked Feb 96 - Sept 97 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.
'
ColCount = Range(MyRange).Columns.Count
RowCount = Range(MyRange).Rows.Count
CalcState = Application.Calculation
StatusBarState = Application.DisplayStatusBar
Application.Calculation = xlManual
Calculate
Application.StatusBar = "Please be patient..."
MyTitle = Range(MyRange).Cells(1, 1) ' Use first cell as title
If Len(Dir(DocDestination)) > 1 Then Kill DocDestination
Open DocDestination For Output As 1
'create Code
Print #1, "" & Chr$(13)
Print #1, "" & Chr$(13)
Print #1, "" & MyTitle & "" & Chr$(13)
Print #1, "" & Chr$(13)
Print #1, "" & Chr$(13)
'Print #1, "" & MyTitle & "" & Chr$(13)
While Row < RowCount
Row = Row + 1
DoEvents
Application.StatusBar = Str$(Int((Row / RowCount) * 100)) & "% Completed"
If (Not Range(MyRange).Rows(Row).Hidden) Then
MV = ""
Col = 0
While Col < ColCount
Col = Col + 1
If (Not Range(MyRange).Columns(Col).Hidden) Then
CellV = Range(MyRange).Cells(Row, Col).Text
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 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 = " ColSpan=" & ColSpan & " Align=center "
End If
CC = Range(MyRange).Cells(Row, Col).Interior.ColorIndex
BGC = ""
If CC = 1 Then BGC = "#000000" 'black"
If CC = 3 Or CC = 22 Then BGC = "#FF6060" 'Red"
If CC = 4 Then BGC = "#80FF80" 'green"
If CC = 6 Or CC = 19 Then BGC = "#FFF3CE" 'yellow"
If CC = 8 Or CC = 41 Then BGC = "#80FFFF" 'blue
If CC = 9 Then BGC = "#C04000" 'burgandy
If CC = 15 Then BGC = "#DFDED0" 'grey"
If CC = 39 Then BGC = "#FF00FF" 'Purple
If Len(BGC) > 2 Then BGC = " bgcolor=" & Chr(34) & BGC & Chr(34)
MV = MV & "" & CellV & ""
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