Attribute VB_Name = "Module1"
Sub 表をHTML形式に変換()
    Const maxRowCheck = 200
    Const maxColCheck = 100
    ReDim spanInfos(maxRowCheck, maxColCheck)
    ReDim tableHtml(maxRowCheck + 2)
    Dim maxRow As Long, maxCol As Long
    Dim numRow As Long, numCol As Long
    Dim strAddress As String
    Dim posC As Long, posColon As Long
    Dim span1stRow As Long, span1stCol As Long
    Dim thisRow As Long, thisCol As Long
    Dim thisLine As String
    Dim thtd As String
    Dim cellText As String
    Dim spanInfo As String
    Dim tempColor As String, styleBGColor As String, styleColor As String
    
    '表のサイズを取得
    For numRow = 1 To maxRowCheck
        For numCol = 1 To maxColCheck
            If Cells(numRow, numCol) <> "" Then
                If maxRow < numRow Then maxRow = numRow
                If maxCol < numCol Then maxCol = numCol
            End If
        Next numCol
    Next numRow
        
    'rowspanとcolspanに関する情報を取得
    For numRow = 1 To maxRow
        For numCol = 1 To maxCol
            strAddress = Cells(numRow, numCol).MergeArea.Address(ReferenceStyle:=xlR1C1)
            posC = InStr(strAddress, "C") '「C」の位置
            posColon = InStr(strAddress, ":") '「:」の位置
            If posColon Then 'コロンあり＝セル結合あり
                span1stRow = CInt(Mid(strAddress, 2, posC - 2))
                span1stCol = CInt(Mid(strAddress, posC + 1, posColon - posC - 1))
                For thisRow = span1stRow To numRow
                    For thisCol = span1stCol To numCol
                        If thisRow = span1stRow And thisCol = span1stCol Then
                            spanInfos(thisRow, thisCol) = " rowspan=" & (numRow - span1stRow + 1) _
                                & " colspan=" & (numCol - span1stCol + 1)
                        Else
                            spanInfos(thisRow, thisCol) = "null"
                        End If
                    Next thisCol
                Next thisRow
            Else
                spanInfos(numRow, numCol) = ""
            End If
        Next numCol
    Next numRow
    
    'HTML(tableタグ)を生成
    tableHtml(0) = "<table>"
    For numRow = 1 To maxRow
        If numRow = 1 Then
            thtd = "th"
        Else
            thtd = "td"
        End If
        thisLine = ""
        For numCol = 1 To maxCol
            cellText = Cells(numRow, numCol).Text
            spanInfo = spanInfos(numRow, numCol)
            If spanInfo <> "null" Then
                '背景色に関する処理
                tempColor = rgb2html(Cells(numRow, numCol).Interior.Color)
                If tempColor <> "#FFFFFF" Then
                    styleBGColor = " style=" & "background-color:" & tempColor
                Else
                    styleBGColor = ""
                End If
                '文字色に関する処理
                tempColor = rgb2html(Cells(numRow, numCol).Font.Color)
                If tempColor <> "#000000" Then
                    styleColor = " style=" & "color:" & tempColor
                Else
                    styleColor = ""
                End If
                'th,tdタグを生成
                thisLine = thisLine & "<" & thtd & spanInfo & styleBGColor & styleColor & ">" _
                    & cellText _
                    & "</" & thtd & ">"
            End If
        Next numCol
        tableHtml(numRow) = "<tr>" & thisLine & "</tr>"
    Next numRow
    tableHtml(maxRow + 1) = "</table>"
    
    'HTMLを新しいシートに出力
    Sheets.Add
    numRow = 0
    Do
        Cells(numRow + 1, 1) = tableHtml(numRow)
        numRow = numRow + 1
    Loop Until tableHtml(numRow) = ""
End Sub

Function rgb2html(num)
    '色を表す数値(RGB関数による数値)をHTMLにおける表記(例「#FF00FF」)に変換する。
    Dim ret As String
    Dim i As Long, temp As Long
    ret = ""
    For i = 0 To 2
        temp = num Mod 256
        ret = ret & Format(Hex(temp), "00")
        num = (num - temp) / 256
    Next i
    rgb2html = "#" & ret
End Function