Convert Excel Table into HTML table with VBA code

Actually to convert Excel table into HTML table is to use Save As web page either whole sheet or selection but we also can use VBA code below to convert by selecting table range example below and run the code. New pop up window will open notepad with HTML code inside and immediately can paste into your blog or webpage.

Run below code to get HTML code inside notepad.

VBA Code:

Option Explicit
Sub ToCreateTableForSelectedRange()
    Dim OpnShell As Variant
    Dim FSO, fs As Object
    Dim StrPath As String
    
    Dim iRow As Integer, iCol As Integer
    Dim Cell As Range, Rng As Range
    Dim i As Integer, j As Integer, k As Integer
    Dim l As Integer, x As Integer
    
    Dim DbWitdh() As Double, DbWitdhTot As Double
    Dim DbWitdhP() As String, DbWitdhAcc As Double
    Dim iColSp As Byte
    
    Dim Qto As String, ClEnd As String
    Dim BdOpn As String, BdCls As String
    Dim TdOpn As String, TdCls As String
    Dim TrOpn As String, TrCls As String
    Dim TblOpn As String, TblCls As String
    Dim StrStyle As String, StrTblWd As String
    Dim StrCellSp As String, StrCellPd As String
    Dim StrBdrCol As String, StrBdr As String
    Dim TBdOpn As String, TBdCls As String
    Dim StrCS As String, StrWd As String, StrAl As String
    
    Qto = """": ClEnd = ">"
    BdOpn = "<b>": BdCls = "</b>"
    TdOpn = "<td": TdCls = "</td>"
    TrOpn = "<tr>": TrCls = "</tr>"
    StrStyle = " style=" & Qto & "border-collapse: collapse;"
    StrTblWd = " width: 500px;" & Qto
    StrCellSp = " cellspacing=" & Qto & "0" & Qto
    StrCellPd = " cellpadding=" & Qto & "3" & Qto
    StrBdrCol = " bordercolor=" & Qto & "#000000" & Qto
    StrBdr = " border=" & Qto & "1" & Qto
    TblOpn = "<table" & StrStyle & StrTblWd & StrCellSp & _
    StrCellPd & StrBdrCol & StrBdr & ClEnd
    TblCls = "</table>"
    TBdOpn = "<tbody>": TBdCls = "</tbody>"
    StrCS = " colspan=" & Qto: StrWd = " width=" & Qto
    StrAl = " align=" & Qto & "Center" & Qto
    
    Set Rng = Selection
    If Rng.Rows.Count < 2 Or Rng.Columns.Count < 2 Then
        MsgBox "Please select range with table!": GoTo Line1
    End If
    
    'To Create new Text File
    StrPath = VBA.Environ("UserProfile") & "\Desktop\TableGenerator.txt"
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    'To Check files existance and delete
    On Error Resume Next
    If Dir(StrPath) <> "" Then Kill StrPath
    
    k = 1
    For Each Cell In Rng
        If Cell.Row > iRow And iRow > 0 Then Exit For
        If iRow = 0 Then iRow = Cell.Row
        If iCol = 0 Then iCol = Cell.Column
        ReDim Preserve DbWitdh(k): DbWitdh(k) = Cell.ColumnWidth
        DbWitdhTot = DbWitdhTot + DbWitdh(k)
        iColSp = k
        k = k + 1
    Next

    For x = LBound(DbWitdh) + 1 To UBound(DbWitdh)
        ReDim Preserve DbWitdhP(x)
        If x < UBound(DbWitdh) Then
            DbWitdhP(x) = Round((DbWitdh(x) / DbWitdhTot) * 100, 0)
            DbWitdhAcc = DbWitdhAcc + DbWitdhP(x)
        Else
            DbWitdhP(x) = 100 - DbWitdhAcc
        End If
    Next x
    
    k = 1
    If Dir(StrPath) = "" Then
        Set fs = FSO.CreateTextFile(StrPath, 2)
        With fs
            .WriteLine TblOpn & TBdOpn
            For i = iRow To iRow + Rng.Rows.Count - 1
                l = 1
                .WriteLine TrOpn
                For j = iCol To iCol + iColSp - 1
                    If k = 1 Then
                        .WriteLine TdOpn & StrCS & iColSp & Qto & _
                        StrWd & DbWitdhP(l) & "%" & Qto & StrAl & _
                        ClEnd & BdOpn & Cells(i, j) & BdCls & TdCls
                    Else
                        .WriteLine TdOpn & StrCS & iColSp & Qto & _
                        StrWd & DbWitdhP(l) & "%" & Qto & StrAl & _
                        ClEnd & Cells(i, j) & TdCls
                    End If
                    l = l + 1
                Next j
                .WriteLine TrCls
                k = k + 1
            Next i
            .WriteLine TBdCls & TblCls
        End With
    End If
    
    'Just To Open NotePad Created
    If Err = 0 Then
        OpnShell = Shell("C:\Windows\System32\notepad.exe " & _
        StrPath, vbNormalFocus)
    End If
    On Error GoTo 0
    
Line1:
    'Reset Variables
    iRow = 0: iCol = 0
    Set Cell = Nothing: Set Rng = Nothing
    Erase DbWitdh: DbWitdhTot = 0
    Erase DbWitdhP: DbWitdhAcc = 0
    iColSp = 0
End Sub

The result in HTML as below:

No.				Subject				Score				Grade
1				English				100
2				Mathematics				65
3				Science				30
4				Physics				55
5				History				20
6				Chemistry				48
7				Biology				70
8				Geography				90

Practice makes perfect. Thank You.