Excelの表をシンプルなTableのHTMLに変換するマクロを作成しました。装飾とかは一切なし、結合されたセルがあればそれはHTML上でも結合してくれる、くらいのものです。ずっと
を利用させていただいているのですが、人様のサイトはいつなくなるか分からないし、カスタマイズはなかなかできないし、ということで自作した次第。コード出しておくのでカスタマイズはご随意に。
～ 目次 ～
動作説明
Excelにこんなデータがあったとします。
A1～C6までをマウスでドラッグして選択し、マクロを実行します。
処理が終わるとメッセージボックスが出ます。
そうすると、クリップボードに対応するHTMLが張り付いています。ペーストしてご利用ください。HTMLを貼り付けたイメージは以下です。
| 列1 | 列2 | 列3 |
|---|---|---|
| 項目1-1 | 項目1-2 | 項目1-3 |
| 縦に3つ結合 | 横に2つ結合 | |
| 項目3-2 | 項目3-3 | |
| 項目4-2 | 項目4-3 | |
| 横に3つ結合 | ||
生成したコードは以下です。
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 |
<table> <thead> <tr> <th>列1</th> <th>列2</th> <th>列3</th> </tr> </thead> <tr> <th>項目1-1</th> <th>項目1-2</th> <th>項目1-3</th> </tr> <tr> <th rowspan='3'>縦に3つ結合</th> <th colspan='2'>横に2つ結合</th> </tr> <tr> <th>項目3-2</th> <th>項目3-3</th> </tr> <tr> <th>項目4-2</th> <th>項目4-3</th> </tr> <tr> <th colspan='3'>横に3つ結合</th> </tr> </table> |
めっちゃシンプルです。まあこのくらいで僕は足りているので。
飛び地のある表に関してはこんな風になります。
上図のが以下のように出力されます。結合とかをExcel上できれいにして、HTML作ってねって感じですね。
| 列1 | 列2 | 列3 |
|---|---|---|
| 項目1-1 | 項目1-2 | 項目1-3 |
| 縦に3つ結合 | 横に2つ結合 | |
| 項目3-2 | 項目3-3 | |
| 項目4-2 | 項目4-3 | |
| 横に3つ結合 | ||
| 飛び地1 | 飛び地2 | 飛び地3 |
コードは以下
コードは以下です。Excelのマクロに登録すれば動きます。
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 |
Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hWnd As LongPtr) As LongPtr Private Declare PtrSafe Function CloseClipboard Lib "user32" () As LongPtr Private Declare PtrSafe Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As LongPtr) As LongPtr Private Declare PtrSafe Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As LongPtr) As LongPtr Private Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr Private Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As LongPtr, Source As Any, ByVal Length As LongPtr) Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As LongPtr Sub ConvertRangeToHTMLTable() Dim rng As Range Dim cell As Range Dim HTML As String Dim RowSpan As Integer Dim ColSpan As Integer Dim DataObj As Object ' 選択範囲を設定 Set rng = Selection ' HTMLテーブルの開始 HTML = "<table>" & vbCrLf ' ヘッダー行の処理 HTML = HTML & vbTab & "<thead>" & vbCrLf HTML = HTML & vbTab & vbTab & "<tr>" & vbCrLf For Each cell In rng.Rows(1).Cells ColSpan = cell.MergeArea.Columns.Count If ColSpan > 1 Then HTML = HTML & vbTab & vbTab & vbTab & "<th colspan='" & ColSpan & "'>" & cell.Value & "</th>" & vbCrLf Else HTML = HTML & vbTab & vbTab & vbTab & "<th>" & cell.Value & "</th>" & vbCrLf End If Next cell HTML = HTML & vbTab & vbTab & "</tr>" & vbCrLf HTML = HTML & vbTab & "</thead>" & vbCrLf ' データ行の処理 For i = 2 To rng.Rows.Count HTML = HTML & vbTab & "<tr>" & vbCrLf For Each cell In rng.Rows(i).Cells If cell.Row = i Then RowSpan = cell.MergeArea.Rows.Count ColSpan = cell.MergeArea.Columns.Count If cell.MergeArea.Cells(1).Address = cell.Address Then If RowSpan > 1 And ColSpan > 1 Then HTML = HTML & vbTab & vbTab & "<th rowspan='" & RowSpan & "' colspan='" & ColSpan & "'>" & cell.Value & "</th>" & vbCrLf ElseIf RowSpan > 1 Then HTML = HTML & vbTab & vbTab & "<th rowspan='" & RowSpan & "'>" & cell.Value & "</th>" & vbCrLf ElseIf ColSpan > 1 Then HTML = HTML & vbTab & vbTab & "<th colspan='" & ColSpan & "'>" & cell.Value & "</th>" & vbCrLf Else HTML = HTML & vbTab & vbTab & "<th>" & cell.Value & "</th>" & vbCrLf End If End If End If Next cell HTML = HTML & vbTab & "</tr>" & vbCrLf Next i ' HTMLテーブルの終了 HTML = HTML & "</table>" ' クリップボードにHTMLをコピー CopyTextToClipboard HTML MsgBox ("クリップボードへの出力終了") End Sub Sub CopyTextToClipboard(text As String) Dim hGlobalMemory As LongPtr, lpGlobalMemory As LongPtr Dim dwSize As LongPtr ' テキストのサイズ（バイト単位） dwSize = LenB(text) + 1 ' グローバルメモリを割り当て hGlobalMemory = GlobalAlloc(&H2002, dwSize) If hGlobalMemory <> 0 Then ' グローバルメモリをロックしてポインタを取得 lpGlobalMemory = GlobalLock(hGlobalMemory) ' テキストをグローバルメモリにコピー CopyMemory lpGlobalMemory, ByVal StrPtr(text), dwSize ' グローバルメモリのロックを解除 GlobalUnlock hGlobalMemory ' クリップボードを開く If OpenClipboard(0&) <> 0 Then ' クリップボードの内容をクリア Call EmptyClipboard ' データをクリップボードに設定 Call SetClipboardData(13, hGlobalMemory) ' クリップボードを閉じる Call CloseClipboard End If End If End Sub |
難しいところはそう無いと思うので、CSSの指定など入れたい人はマクロを適宜修正すれば簡単に修正できると思います。
動作上の注意
動作確認したExcelのバージョンは以下です。これ以外の動作確認はしていません。特に32ビットとかどう動くかわからんです。
Microsoft® Excel® for Microsoft 365 MSO (バージョン 2310 ビルド 16.0.16924.20054) 64 ビット
Excelの表面をなめてクリップボード処理をしているだけなので悪さするとも思えませんが、このマクロを使うことでどのような損害が出ても僕は責任を持ちません。
このマクロ、ChatGPTで作った
このマクロ、ChatGPTで作りました。欲しいものを日本語で入力して、出力されたコードを貼り付けて動作テスト。何度か「追加発注」をしてコードを直してもらい、バグっぽい所は自分でちょっとだけ調べてコード修正しました。この程度のものなら30分くらいでできてしまうんですねえ。いい時代です。
