Sub CreateFinStmt()
' Three parameters must be supplied - the table name, a folder location, an HTML filename
MakeHTable "finstmt", "C:\mydata\", "J1_finstmt.htm"
End Sub
Sub MakeHTable(MyTblname As String, MyFileLocn As String, MyFileName As String)
' *** save a single named table as an HTML file ***
' This macro was originally written by Chris Mead (www.meadinkent.co.uk)
' You are free to use it for private use provided this copyright message is left unchanged.
Dim PageName As String, FirstRow As Integer, LastRow As Integer
Dim FirstCol As Integer, LastCol As Integer, MyBold As Byte, MySize As Integer
Dim TempStr As String, MyRow As Integer, MyCol As Integer, InsideTD As String
Dim Vtype As Integer, DefFontSize As Integer, PageStr As String
Dim MergeCount As Integer, MyCell As Range, HL_Locn As String
Dim MyWidths() As Single, TotWidth As Single
Dim MyRngName As Name, StartRng As String
DefFontSize = 10 ' this is the default size on the spreadsheet. Text which is larger or smaller will be modified
If Right(MyFileLocn, 1) <> "\" Then MyFileLocn = MyFileLocn & "\"
For Each MyRngName In Names ' Loop through each named range
If UCase(MyRngName.Name) = UCase(MyTblname) Then ' if the range name matches the Table name parameter ...
If MyFileName = "X" Then
PageName = MyFileLocn & "h_" & MyRngName.Name & ".htm"
Else
PageName = MyFileLocn & MyFileName
End If
FirstRow = Range(MyRngName).Row ' *** the range of the worksheet to be ***
LastRow = Range(MyRngName).Rows.Count + FirstRow - 1 ' *** converted into an HTML table ***
FirstCol = Range(MyRngName).Column
LastCol = Range(MyRngName).Columns.Count + FirstCol - 1
TotWidth = 0
ReDim MyWidths(LastCol)
For MyCol = FirstCol To LastCol
MyWidths(MyCol) = Cells(FirstRow, MyCol).ColumnWidth
TotWidth = TotWidth + MyWidths(MyCol)
' Debug.Print MyCol, MyWidths(MyCol)
Next
Open PageName For Output As #1
Print #1, ""
Print #1, ""
Print #1, "Excel table converted to HTML - MeadInKent"
' --- these lines add some CSS instructions ---
Print #1, ""
Print #1, ""
Print #1, ""
Print #1, ""
'an initial row to set col widths to those on the worksheet
For MyCol = FirstCol To LastCol
Print #1, " | "
Next MyCol
Print #1, ""
For MyRow = FirstRow To LastRow
Print #1, ""
MyCol = FirstCol
Do While MyCol <= LastCol
Set MyCell = Cells(MyRow, MyCol) ' sets variable to the current cell
MyBold = 0
MySize = 0
If MyCell.Font.Bold = True Then MyBold = 1
If MyCell.Font.Size > DefFontSize Then MySize = 1
If MyCell.Font.Size < DefFontSize Then MySize = 2
Vtype = 0 ' check whether the cell is numeric
If IsNumeric(MyCell.Value) Then Vtype = 1
If IsDate(MyCell.Value) Then Vtype = 2
If IsEmpty(MyCell.Value) Then Vtype = 3
If "-" & MyCell.Value & "-" = "--" Then
TempStr = " " ' a space character to be entered in empty cells
Else
' if numeric apply the cell format code
If Vtype > 0 Then
TempStr = Format(MyCell.Value, CleanFormat(MyCell.NumberFormat))
Else
TempStr = MyCell.Value
End If
If InStr(1, TempStr, "£") > 0 Then
TempStr = Replace(TempStr, "£", "£")
End If
If MyBold = 1 Then
TempStr = "" & TempStr & ""
End If
If MySize = 1 Then
TempStr = "" & TempStr & ""
End If
If MySize = 2 Then
TempStr = "" & TempStr & ""
End If
If MyCell.Font.ColorIndex <> 1 And MyCell.Font.ColorIndex <> -4105 Then
TempStr = "" & TempStr & ""
End If
End If
'if cells are merged, count the number of columns. If not merged it will return 1
MergeCount = MyCell.MergeArea.Columns.Count
InsideTD = ChkB(MyRow, MyCol) ' ChkB is a function in this module to set Border commands
If MergeCount > 1 Then
InsideTD = InsideTD & " align='left' colspan='" & Format(MergeCount, "#") & "'"
MyCol = MyCol + MergeCount - 1
Else
If (Vtype = 1 or Vtype=2) And InStr(InsideTD, "align") = 0 Then InsideTD = InsideTD & " align='right'"
End If
TempStr = "| " & TempStr & " | "
Print #1, TempStr
MyCol = MyCol + 1
Loop ' MyCol
Print #1, "
"
Next MyRow
Print #1, "
"
Print #1, "Table '" & MyTblname & "' generated at " & Format(Now(), "hh:mm ddd dd mmm yy") & "
"
Print #1, "Filename: '" & MyFileLocn & MyFileName & " [created using MakeHTable() from MeadInKent.co.uk]
"
Print #1, ""
Close #1
End If
Next MyRngName
If MyFileName = "X" Then
Debug.Print Time(), "MakeHTable(h_" & MyTblname & ".htm) completed"
Else
Debug.Print Time(), "MakeHTable()", MyTblname, MyFileLocn & MyFileName, FirstRow; ","; FirstCol, LastRow; ","; LastCol
End If
End Sub
Function CleanFormat(MyNumCode As String)
Dim xMyNumCode As String, n As Integer, SectCount As Integer
' transform and make a NumberFormat code suitable for Format() function
If MyNumCode = "General" Then
CleanFormat = "0"
Exit Function
End If
n = 1
Do While n < Len(MyNumCode)
If Mid(MyNumCode, n, 1) = ";" Then
SectCount = SectCount + 1
If SectCount = 2 Then
MyNumCode = Left(MyNumCode, n) & "0"
Exit Do
End If
End If
n = n + 1
Loop
'Debug.Print 2, MyNumCode
n = 1
Do While n < Len(MyNumCode)
If Mid(MyNumCode, n, 1) = "_" Or Mid(MyNumCode, n, 1) = "*" Then
If n = 1 Then
MyNumCode = Mid(MyNumCode, 3, 100)
Else
MyNumCode = Left(MyNumCode, n - 1) & Mid(MyNumCode, n + 2, 100)
End If
n = n - 1
End If
n = n + 1
Loop
' the next 2 line fix an apparent bug with the Format function in VBA
MyNumCode = Replace(MyNumCode, "0.00,", "0,.00")
MyNumCode = Replace(MyNumCode, "0.0,", "0,.0")
CleanFormat = MyNumCode
End Function
Function GetRGB(RGB As Long) As String
' convert an Excel colour value into a Hex value suitable for HTML
Dim Red As Integer, Green As Integer, Blue As Integer
Red = RGB And 255
Green = RGB \ 256 And 255
Blue = RGB \ 256 ^ 2 And 255
GetRGB = "#" & Format(Hex(Red), "00") & Format(Hex(Green), "00") & Format(Hex(Blue), "00")
End Function
Function ChkB(MyRow As Integer, MyCol As Integer) As String
' add borders and table cell properties
Dim Temp As String, MyLine(10) As String, x As Variant
Dim cmW As String, cmS As String
MyLine(7) = "border-left: "
MyLine(8) = "border-top: "
For n = 7 To 8
' left 7 top 8 btm 9 right 10
'Debug.Print GetRGB(Cells(MyRow, MyCol).Borders(n).Color), Cells(MyRow, MyCol).Borders(n).Weight, Cells(MyRow, MyCol).Borders(n).LineStyle
If Cells(MyRow, MyCol).Borders(n).LineStyle = -4142 Then
MyLine(n) = MyLine(n) & " none; "
Else
' weight thick 4 thin 2 medium -4138
x = Cells(MyRow, MyCol).Borders(n).Weight
If x = -4138 Then
cmW = " 1.5pt"
ElseIf x = 4 Then
cmW = " 2.5pt"
Else
cmW = " 1.0pt"
End If
' linestyle 1 solid -4118 dotted -4142 0
x = Cells(MyRow, MyCol).Borders(n).LineStyle
If x = -4118 Then
cmS = " dotted"
Else
cmS = " solid"
End If
MyLine(n) = MyLine(n) & GetRGB(Cells(MyRow, MyCol).Borders(n).Color) & cmW & cmS & "; "
End If
'Debug.Print MyLine(n)
ChkB = ChkB & MyLine(n)
Next
ChkB = "style ='" & Left(Trim(ChkB), Len(Trim(ChkB)) - 1) & "'"
If ChkB = "style ='border-left: none; border-top: none'" Then ChkB = ""
If ChkB = "style ='border-left: none; border-top: #000000 1.0pt solid'" Then ChkB = "Class='TopLine'"
If Cells(MyRow, MyCol).Interior.Color <> 16777215 Then
ChkB = ChkB & " bgcolor='" & GetRGB(Cells(MyRow, MyCol).Interior.Color) & "'"
End If
If Cells(MyRow, MyCol).HorizontalAlignment = xlHAlignRight Then
ChkB = ChkB & " align='right'"
End If
If Cells(MyRow, MyCol).HorizontalAlignment = xlHAlignCenter Then
ChkB = ChkB & " align='center'"
End If
End Function