Excelの表をHTMLのtableに変換するマクロ

HTMLで表を作るにはtableタグを使いますが、結構、面倒です。
Excelで表を作り、HTMLとして保存することができますが、余計なタグが満載です。
Excelの表から必要最小限のHTML(tableタグ)に変換するマクロを作ってみました。

仕様
サンプル
コード(メイン)
コード(色に関する処理)
コード全体

仕様

アクティブシートに対して実行すると、新しいシートを追加して出力する。
表はA1セルを左端、上端とする。
表以外のセルに値をセットしない。
先頭行のセルはthタグ、それ以外はtdタグとする。
セルの結合に対応する。
文字色、背景色に対応する。

サンプル

次のようにシートにセットします。

次のように出力されます。

コード(メイン)

セルの結合に関する処理と色に関する処理があるため長くなっています。
まず表のサイズを取得します。デフォルトで200行、100列の全てのセルをチェックし値があるセルの下端と右端を探します。
セルの結合はrowspanとcolspanを設定することで表現します。上で取得した表の全てのセルをチェックしセルの結合があればrowspanとcolspanの大きさを調べます。
色は文字色と背景色について調べます。詳細は後述します。
これらの情報を元に、table, tr, th/tdを使って表を生成します。
最後にシートを追加し、HTMLを出力します。

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

コード(色に関する処理)

前に紹介した「Excelの色をHTMLに変換」を利用してセルの色情報を表す数値(RGB関数による数値)をHTMLにおける表記(例「#FF00FF」)に変換します。

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

コード全体

コード全体をテキストファイルにしました。
上のコードをコピー＆ペーストしてもいいですが、次のファイルをダウンロードし、拡張子を「.txt」を「.bas」に変更してインポートすると簡単です。

html_table.txt

M より:

2020年5月1日 13:02

office365を使っていますが、最後の1列だけ出力されます。
操作手順など注意点はありますでしょうか。

stabucky より:

2020年5月4日 08:05

＞Mさん
返信が遅くなりすみません。
コードに誤りがありました。
修正いたしましたので再度確認いただけると助かります。
よろしくおねがいします。