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 = "" Print #1, TempStr MyCol = MyCol + 1 Loop ' MyCol Print #1, "" Next MyRow Print #1, "
" & TempStr & "
" 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