To Create Hyperlink with Excel VBA

 In Microsoft Excel to insert Hyperlink just click at Insert Tab and click at Link world icon with chain. Key in Text to display, add ScreenTip if you wish and select link or location. To convert into HTML we have save this selection link as webpage and publish. We also can use VBA code to convert this link into HTML code. For example we have table as below.

Run below code to get HTML code inside notepad.

VBA Code:

Option Explicit
Sub ToCreate_HyperLinkListing_Reference()
        
    Dim OpenShell As Variant
    Dim FSO, fs As Object
    
    Dim MstWS As Worksheet
    Dim StrPath As String
    Dim Rw As Long
    
    Dim BrktCls As String, Qto As String
    Dim HpLinkOpn As String, HpLinkCls As String
    Dim TtlTag As String, StrTgt As String
    Dim BrTag As String
    Dim pTgOpn As String, pTgCls As String
    
    Dim StrTitle As String, StrAchText As String, StrLink As String
    
    'Assign Variables
    Set MstWS = ActiveSheet
    BrktCls = ">": Qto = """"
    HpLinkOpn = "<a href=": HpLinkCls = "</a>"
    TtlTag = " title="
    StrTgt = "target=" & Qto & "_blank" & Qto
    BrTag = "<br />"
    pTgOpn = "<p>": pTgCls = "</p>"
    
    'To Create new Text File
    StrPath = VBA.Environ("UserProfile") & "\Desktop\MacroReadMe.txt"
    
    'Create Object to open Notepad
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    'To Check files existance and delete old file
    On Error Resume Next
    If Dir(StrPath) <> "" Then Kill StrPath

    'To write into NotePad
    If Dir(StrPath) = "" Then
        Set fs = FSO.CreateTextFile(StrPath, 2)
        With fs
            Rw = 3
            Do While MstWS.Range("B" & Rw) <> ""
            
                StrTitle = MstWS.Range("C" & Rw)
                StrAchText = MstWS.Range("B" & Rw)
                StrLink = MstWS.Range("D" & Rw)
                
                .WriteLine HpLinkOpn & Qto & StrLink & Qto & TtlTag & _
                Qto & StrTitle & Qto & " " & StrTgt & BrktCls & _
                StrAchText & HpLinkCls & BrTag
                
                StrTitle = "": StrAchText = "": StrLink = ""
                Rw = Rw + 1
            Loop
        End With
    End If

    'Just To Open NotePad Created
    If Err = 0 Then
        OpenShell = Shell("C:\Windows\System32\notepad.exe " & _
        StrPath, vbNormalFocus)
    End If
    On Error GoTo 0
    
    'Reset Variables
    StrPath = ""
    BrktCls = "": Qto = ""
    HpLinkOpn = "": HpLinkCls = ""
    TtlTag = "": BrTag = ""
End Sub

The result in HTML as below:

Microsoft Excel VBA
Computer Resources
Digital Camera Resources
Computer Games Collection

Practice makes perfect. Thank You.

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.