'セル範囲からHTMLのTableを作成するマクロ（超簡易版）

'セル範囲を選択して、WriteHTMLTableマクロを実行してください。
'右詰め左詰め等の配置は明示的に指定しておいてください。

Option Explicit

Sub WriteHTMLTable()
    Dim range1 As Range, range2 As Range
    On Error GoTo err_1
    If TypeName(Selection) <> "Range" Then
        MsgBox "セル範囲を選択して実行してください。", _
            vbExclamation, "HTMLTableの作成"
        Exit Sub
    End If
    Set range1 = Selection.Areas(1)
    Set range2 = Workbooks.Add(xlWorksheet).Worksheets(1).Cells(1, 1)
    If Not WriteHTMLTable2(range1, range2) Then
        MsgBox "文字が入りきらなかったセルがあります。確認してください。", _
            vbExclamation, "HTMLTableの作成"
    End If
    range2.CurrentRegion.Select
    Selection.Copy
    Exit Sub
err_1:
    MsgBox Error(Err) & " (" & Err & ")", vbExclamation, "HTMLTableの作成"
End Sub

'HTMLをセルに出力する関数
'もし文字が入りきらないセルがあったらFalseを返す。

Function WriteHTMLTable2(range1 As Range, range2 As Range) As Boolean
    Dim i As Integer
    Dim r As Range, r2 As Range, r3 As Range
    Dim s As String, s2 As String

    WriteHTMLTable2 = True

    Set r2 = range2.Cells(1, 1)
    WriteString r2, "<TABLE BORDER>"
    For Each r In range1.Rows
        WriteString r2, "<TR>"
        For Each r3 In r.Cells
            Select Case r3.HorizontalAlignment
                Case xlCenter
                    s = "<TD ALIGN=""CENTER"">"
                Case xlLeft
                    s = "<TD ALIGN=""LEFT"">"
                Case xlRight
                    s = "<TD ALIGN=""RIGHT"">"
                Case Else
                    s = "<TD>"
            End Select
            s2 = Trim$(r3.Text)
            If Len(s2) = 0 Then
                s = s & "&nbsp;</TD>"
            Else
                s = s & MyConvertToHTML(s2) & "</TD>"
            End If
            If Not WriteString(r2, s) Then WriteHTMLTable2 = False
        Next
        WriteString r2, "</TR>"
    Next
    WriteString r2, "</TABLE>"
End Function

'セルへの出力を行う関数
Function WriteString(ByRef range1 As Range, s As String) As Boolean
    range1.Value = s
    WriteString = (Len(range1.Value) = Len(s))
    Set range1 = range1.Offset(1)
End Function

'特殊文字（<、>、& のみ）をエスケープシーケンスに変換する関数
Function MyConvertToHTML(string1 As String) As String
    Dim i As Long
    Dim s As String

    For i = 1 To Len(string1)
        Select Case Mid$(string1, i, 1)
            Case "<"
                s = s & "&lt;"
            Case ">"
                s = s & "&gt;"
            Case "&"
                s = s & "&amp;"
            'Case """"
            '    s = s & "&quot;"
            Case Else
                s = s & Mid$(string1, i, 1)
        End Select
    Next
    MyConvertToHTML = s
End Function