Sub ExportRangeAsHTML(SourceRange As Range, TargetFile As String, _
TableSize As String, UseRangeColumnWidths As Boolean, _
TableBorderSize As Integer, CellPadding As Integer, _
CellSpacing As Integer, IncludeEmptyCells As Boolean)
' Exports the data in SourceRange to the textfile TargetFile in HTML format
' Example: ExportRangeAsHTML Range("A3:E23"), "C:\FolderName\HtmlText.htm", "", True, 1, 5, 0, True
Dim A As Integer, r As Long, c As Integer, totr As Long, pror As Long
Dim fn As Integer, LineString As String, tLine As String, CellColumnWidth As Long
Dim BoldCell As Boolean, ItalicCell As Boolean, CellAlignment As Integer
' validate the input data if necessary
If SourceRange Is Nothing Then Exit Sub
If Len(TargetFile) = 0 Then Exit Sub
If Application.WorksheetFunction.CountA(SourceRange) = 0 Then
If Not IncludeEmptyCells Then Exit Sub
End If
On Error Resume Next
Kill TargetFile
On Error GoTo 0
If Len(Dir(TargetFile)) > 0 Then
MsgBox TargetFile & " already exists, rename, move or delete the file before you try again.", vbInformation, "Export range to textfile"
Exit Sub
End If
' perform export
On Error GoTo NotAbleToExport
fn = FreeFile
Open TargetFile For Append As #fn ' open textfile for new input
On Error GoTo 0
' determine the total number of rows to process
totr = 0
For A = 1 To SourceRange.Areas.Count
totr = totr + SourceRange.Areas(A).Rows.Count
Next A
' start the HTML file
Print #fn, ""
Print #fn, ""
Print #fn, ""
Print #fn, ""
Print #fn, "Range to HTML from " & ActiveWorkbook.Name & ""
Print #fn, ""
Print #fn,
Print #fn, ""
Print #fn, "Range to HTML from " & ActiveWorkbook.Name & "
"
Print #fn,
If TableSize = "" Then
Print #fn, ""
Else
Print #fn, ""
End If
' start writing the HTML-file
pror = 0
For A = 1 To SourceRange.Areas.Count
For r = 1 To SourceRange.Areas(A).Rows.Count
If pror Mod 50 = 0 Then
Application.StatusBar = "Writing the HTML-file " & Format(pror / totr, "0 %") & "..."
End If
Print #fn, " "
For c = 1 To SourceRange.Areas(A).Columns.Count
LineString = " "
CellAlignment = 0
tLine = ""
On Error Resume Next
With SourceRange.Areas(A).Cells(r, c)
tLine = Trim(.Text)
BoldCell = .Font.Bold
ItalicCell = .Font.Italic
CellAlignment = .HorizontalAlignment
End With
On Error GoTo 0
If (tLine = "" Or tLine = " ") And IncludeEmptyCells Then tLine = " "
If tLine <> "" Then
LineString = LineString & ""
If BoldCell Then LineString = LineString & ""
If ItalicCell Then LineString = LineString & ""
LineString = LineString & tLine
If ItalicCell Then LineString = LineString & ""
If BoldCell Then LineString = LineString & ""
LineString = LineString & ""
Print #fn, LineString
End If
Next c
Print #fn, "
"
pror = pror + 1
Next r
Next A
' end the HTML file
Print #fn, "
"
Print #fn,
Print #fn, ""
Print #fn, ""
Close #fn ' close the targetfile
NotAbleToExport:
Set SourceRange = Nothing
Application.StatusBar = False
End Sub