HTMLの表組を作るマクロ

http://q.hatena.ne.jp/1277360031
こちらの質問ではExcelの表組をそのままHTMLの表組にするマクロを回答しました。
その発展形として機能を追加したものです。

• 枠組み
• 背景色
• 文字色
• アラインメント
• リンク
• セル幅と高さ

に対応させました。

色についてはid:ken3memo さんの三流君のサイトのRGBを入れ替えるコードを参考にさせていただきました。

最終的な目的は回答欄で使えるTABLEタグを作成し、人力の回答で見栄えの良い表を作ることが目的ですのでこれ以上の拡張はしない予定です。

Sub HTMLの表組を作るマクロ()
    Dim str As String
    Dim r As Range
    Dim i As Long
    Dim j As Long
    Dim CB As New DataObject
    Dim f As Boolean
    Dim cCount As Integer
    Dim rCount As Integer
    Dim cSpan As String
    Dim rSpan As String
    Dim fnColor As String
    Dim fnColorEd As String
    Dim bgColor As String
    Dim strColor As String
    Dim linkSt As String
    Dim linkEd As String
    Dim align As String
    Dim valign As String
    Dim sWidth As String
    Dim sHeight As String
    Dim colH() As Boolean
    Dim rowH() As Boolean
    
    Set r = Selection
    
    ReDim colH(r.Columns.Count - 1)
    ReDim rowH(r.Rows.Count - 1)
    
    str = "<table border>" & vbNewLine
    For i = r.Row To r.Row + r.Rows.Count - 1
        str = str & "<tr>" & vbNewLine
        For j = r.Column To r.Column + r.Columns.Count - 1
            f = True
            rSpan = ""
            cSpan = ""
            rCount = 0
            cCount = 0
            linkSt = ""
            linkEd = ""
            bgColor = ""
            fnColor = ""
            fnColorEd = ""
            sWidth = ""
            sHeight = ""
            
            If i > 1 Then
                If Not Intersect(Cells(i, j), Cells(i - 1, j).MergeArea) Is Nothing Then
                    f = False
                End If
            End If
            If j > 1 Then
                If Not Intersect(Cells(i, j), Cells(i, j - 1).MergeArea) Is Nothing Then
                    f = False
                End If
            End If
            If f Then
                While Not Intersect(Cells(i, j + cCount), Cells(i, j).MergeArea) Is Nothing
                    cCount = cCount + 1
                Wend
                If cCount > 1 Then
                    cSpan = " colspan=" & cCount
                End If
                While Not Intersect(Cells(i + rCount, j), Cells(i, j).MergeArea) Is Nothing
                    rCount = rCount + 1
                Wend
                If rCount > 1 Then
                    rSpan = " rowspan=" & rCount
                End If
                
                strColor = Right("000000" & Hex(Cells(i, j).Interior.Color), 6)
                If strColor <> "FFFFFF" Then
                    bgColor = " bgcolor=#" & Mid(strColor, 5, 2) & Mid(strColor, 3, 2) & Mid(strColor, 1, 2)
                End If
                
                strColor = Right("000000" & Hex(Cells(i, j).Font.Color), 6)
                If strColor <> "000000" Then
                    fnColor = "<font color=#" & Mid(strColor, 5, 2) & Mid(strColor, 3, 2) & Mid(strColor, 1, 2) & ">"
                    fnColorEd = "</font>"
                End If
                
                If Cells(i, j).Hyperlinks.Count > 0 Then
                    linkSt = "<a href=" & Cells(i, j).Hyperlinks(1).Address & ">"
                    linkEd = "</a>"
                End If
                
                Select Case Cells(i, j).HorizontalAlignment
                    Case xlCenter
                        align = " align=center"
                    Case xlRight
                        align = " align=right"
                    Case xlJustify
                        align = " align=justify"
                    Case Else
                        align = " align=left"
                End Select
                
                Select Case Cells(i, j).VerticalAlignment
                    Case xlTop
                        valign = " valign=top"
                    Case xlBottom
                        valign = " valign=bottom"
                    Case xlCenter
                        valign = " valign=center"
                    Case xlJustify
                        valign = " valign=justify"
                End Select
                                
                If Not rowH(i - 1) Then
                    If i = 1 Then
                        rowH(i - 1) = True
                        sHeight = " height=" & Cells(i, j).MergeArea.Height
                    Else
                        If Intersect(Cells(i, j), Cells(i - 1, j).MergeArea) Is Nothing Then
                            rowH(i - 1) = True
                            sHeight = " height=" & Cells(i, j).MergeArea.Height
                        End If
                    End If
                End If
                
                If Not colH(j - 1) Then
                    If j = 1 Then
                        colH(j - 1) = True
                        sWidth = " width=" & Cells(i, j).MergeArea.Width
                    Else
                        If Intersect(Cells(i, j), Cells(i, j - 1).MergeArea) Is Nothing Then
                            colH(j - 1) = True
                            sWidth = " width=" & Cells(i, j).MergeArea.Width
                        End If
                    End If
                End If
                
                str = str & "<td" & sHeight & sWidth & bgColor & rSpan & cSpan & align & valign & ">" _
                    & fnColor & linkSt & Cells(i, j).Value & linkEd & fnColorEd & "</td>" & vbNewLine
            
            End If
        Next j
        str = str & "</tr>" & vbNewLine
    Next i
    str = str & "</table>"
    
    CB.SetText str
    CB.PutInClipboard
End Sub