今回もエクセルの神髄様の Twitter 企画「VBA100本ノック」の便乗記事です。 今回はその94本目をやります。 ついでにはてなブログで使える Markdown 表組へ変換するマクロも作ります。
お題：VBA100本ノック 94本目：表範囲からHTMLのtableタグを作成
#VBA100本ノック 94本目
— エクセルの神髄 (@yamaoka_ss) 2021年2月23日
表をHTMLの<table>に変換するFunctionを作成。
引数(セル範囲,見出行数)でHTMLで返す。
見出行数：>=1は指定行数を<thead>で出力。
セル結合：<td colspan="2" rowspan="2">等々
空白セル：" "を出力
※出力サンプルを参考に
※文字位置は不要、インデントは任意 pic.twitter.com/ePCjMtc3fJ
方針
今回のお題は本ブログでもいつかやろうとは思っていたネタでした。
このマクロを作れば早く終われた仕事が何回かあったのですが、結局は後回しで手付かず仕舞いでした。
今回踏ん切りをつける機会をいただいて、エクセルの神髄様には感謝申し上げます。
さて、設計的には基本的にセル範囲の行と列のループの中で HTML タグを吐き出していけば、そのまま TABLE の構造を組み上げられそうです。
ただ、お題の要求する「見出し行数の指定」や「結合セルの再現」などのイジワル仕様にも対応しなければなりません。
それには状態による処理の分岐と出力内容の変更を管理しなければならないのですが、この手の問題は気をつけないとすぐに複雑になります。
今は動いても、その後実際に使ってみて改善修正などを加えていけば、セル範囲によるの状態の判定ロジックと HTML 生成の処理とが入り乱れてどんどん読みにくいコードになるでしょう。
ここは状態遷移の管理と HTML 構造生成の定義をどう切り分けられるのかがポイントになります。
解答
Option Explicit ' グローバル変数・定数 ======================================================== Private Type TagState TOM As Variant mode As Variant context As Collection End Type Private gState As TagState Private gOut As Object ' Scripting.Dictionary ' 状態管理 ==================================================================== Sub state_init() gState.TOM = Array( _ Array("table", "thead", "tr", "th"), _ Array("table", "tbody", "tr", "td") _ ) gState.mode = gState.TOM(0) Set gState.context = New Collection state_shift End Sub Sub state_shift() gState.context.Add gState.mode(gState.context.Count) End Sub Sub state_unshift() gState.context.Remove gState.context.Count If gState.context(gState.context.Count) = "table" Then gState.mode = gState.TOM(1) End If End Sub Function state_tag() As String state_tag = gState.context(gState.context.Count) End Function Function state_level() As String state_level = gState.context.Count End Function ' 出力 ======================================================================== Sub out(ParamArray txts() As Variant) gOut.Add gOut.Count + 1, Join(txts, "") End Sub Function out_getResult() As String out_getResult = Join(gOut.Items, "") End Function ' イベントハンドラ ============================================================ Sub onInit(conf As Collection) Call state_init Set gOut = CreateObject("Scripting.Dictionary") End Sub Sub onTerm() End Sub Sub onRangeStart(rng As Range) out indent(state_level()), openTag(state_tag(), attr("border", 1)), vbCrLf state_shift If rng.Areas.Count = 1 Then ' 見出し行がなかったら空送りする state_unshift state_shift End If End Sub Sub onRangeEnd(rng As Range) state_unshift out indent(state_level()), closeTag(state_tag()), vbCrLf End Sub Sub onAreaStart(rng As Range) out indent(state_level()), openTag(state_tag()), vbCrLf state_shift End Sub Sub onAreaEnd(rng As Range) state_unshift out indent(state_level()), closeTag(state_tag()), vbCrLf state_unshift state_shift End Sub Sub onRowStart(rng As Range) out indent(state_level()), openTag(state_tag()), vbCrLf state_shift End Sub Sub onRowEnd(rng As Range) state_unshift out indent(state_level()), closeTag(state_tag()), vbCrLf End Sub Sub onCell(rng As Range) If rng.MergeArea(1).Address = rng.Address Then ' 被結合セルは出力しない Dim rowspan As String Dim colspan As String Dim tag As String With rng.MergeArea rowspan = IIf(.Rows.Count > 1, attr("rowspan", .Rows.Count), "") colspan = IIf(.Columns.Count > 1, attr("colspan", .Columns.Count), "") End With tag = state_tag() out indent(state_level()), openTag(tag, rowspan, colspan), content(rng.Text), closeTag(tag), vbCrLf End If End Sub ' ヘルパー ライブラリ ========================================================= Private Function indent(level As Long) indent = Space((level - 1) * 2) End Function Private Function attr(key As String, val As Variant) As String attr = key & "=""" & esc(CStr(val), "&<""") & """" End Function Private Function openTag(tag, ParamArray attrs() As Variant) As String openTag = "<" & tag & ">" Dim attr As Variant For Each attr In attrs If attr <> "" Then openTag = Replace(openTag, ">", " " & attr & ">") End If Next End Function Private Function closeTag(tag As String) As String closeTag = "</" & tag & ">" End Function Private Function content(ByVal txt As String) If Trim(txt) = "" Then content = " " Else content = Replace(esc(txt), vbLf, "<br>") End If End Function Private Function esc(ByVal txt As String, Optional chars As String = "&<>") As String Dim i As Long Dim ch As String For i = 1 To Len(chars) ch = Mid(chars, i, 1) txt = Replace(txt, ch, "&#" & AscW(ch) & ";") Next esc = txt End Function ' フレームワーク ============================================================== Sub rangeTraverser(rng As Range, Optional ByVal conf As Collection = Nothing) Dim a As Range Dim r As Range Dim c As Range Call onInit(conf) Call onRangeStart(rng) For Each a In rng.Areas Call onAreaStart(a) For Each r In a.Rows Call onRowStart(r) For Each c In r.Cells Call onCell(c) Next Call onRowEnd(r) Next Call onAreaEnd(a) Next Call onRangeEnd(rng) Call onTerm End Sub ' アプリケーション ============================================================ Function VBA100_094(ByVal table As Range, Optional headRowsCount As Long = 0) As String If table.Rows.Count <= headRowsCount Then Err.Raise 9999, "VBA100_094", "見出し行数が多すぎます" ' 見出しとデータ部を分離 If headRowsCount > 0 Then Dim thead As Range Dim tbody As Range Set thead = table.Resize(headRowsCount) Set tbody = Intersect(table, table.Offset(headRowsCount)) Set table = Range(thead.Address & "," & tbody.Address) End If ' HTML TABLEに変換 Call rangeTraverser(table) VBA100_094 = out_getResult() End Function Sub testVBA100_094() Debug.Print VBA100_094(Range("B2").CurrentRegion, 2) End Sub
考察
だいぶ長いプログラムになりました。 一応レイヤーに分かれているのでとりあえずコメントで区切ってもみましたがどうでしょうか。
関心と責務が分離されて分りやすいと感じたでしょうか。
それともロジックが散っていて、どこで何をやっているのか分かりにくいと感じたでしょうか。
フレームワーク
セル範囲を走査するループ処理はセルを辿ることに専念し、節目となるタイミングでイベントハンドラを呼び出すだけです。 節目はRange -> Area -> Row -> Cell という階層構造に従います。
具体的な処理は各イベントハンドラの実装にまかせることになります。
見出し行の行数なども、パラメータを使わずに、セル範囲の構造（Areas）として表現されることになります。
これをフレームワークというのも大げさかと思うかもしれませんが、この仕掛け自体は思いのほか汎用性が高いので、別の課題にも流用できそうです。
イベントハンドラ
各イベントハンドラがやるべき仕事は適切な HTML タグとセルの内容を組み立てて出力し、タグの状態を進めることです。
今、何タグを出すべきかは、gState で状態管理されているので、受け取ったタグを見ることもなくそのまま出力するだけです。
HTML の文字列操作はライブラリとして切り出されているので、その煩雑さにかかずらうことはありません。
出力先は out 関数に文字列を順番に渡しているだけで、その先のリソース管理には関知しません。
そうすると、イベントハンドラでは何をしたらいいのでしょうか。
イベントハンドラで注力すべきは処理の仕様、いわゆるビジネスロジックのみです。
将来的に、セル範囲のスタイルの反映など複雑な対応が必要となったとしても、イベントハンドラのタイミングと状態、対象範囲の Range があれば、大抵の場合で HTML の構築には困らないはずです。
状態管理
もうひとつの、ビジネスロジックに関わる実装としては状態管理があります。
ここでは、 gState というグローバル変数に、タグの状態を管理するデータを持たせていますが、本来はクラスモジュールに切り出して、クラスとして定義すべきでしょう。
現在の状態は contextでタグのスタックとして表現されます。
mode では見出し行とデータ行で使用するタグセットの切り替えを行います。
TOM （Table Object Model のつもり）はテーブルの構造と状態遷移のルール（の一部）を定義しています。
状態遷移のルールの定義は、条件分岐を多用したコードより、データか宣言として表現できた方がメンテ的に望ましいのですが、VBA の表現力では限界があるようで中途半端に終わりました。
出力
処理と出力は切り分られていると、必要に応じて出力先を差し替えるなどの改修が楽になります。
そのため out 関数は出力方法を隠ぺいします（見えちゃってますが）
out 関数の先でバッファーに保持されているのか、ファイルに出力されているのかなど具体的な出力方法に呼び出し側は関知しません。
これも本来クラス化すべきだったかもしれません。 VBA でもインターフェースの定義ができるようなので、いろいろできそうですが、今回の課題の範囲としては広げすぎでしょう。
ヘルパーライブラリ
HTML の文字列操作をライブラリとして掃き出して整理したことで、コードがすっきりとしてロジックの見通しが良くなりました。
この HTML ライブラリは 標準の HTML の仕様にのみ依存するので、共有コードとして大事に育てれば重宝するでしょう。
Excel 表をはてな Markdown としてコピーするマクロ
ところでこのブログの記事は、HTMLではなく、はてなブログの Markdown モードで編集しています。
Markdown はシンプルなマークアップが良いのですが、表組みだけは記述が非常に面倒くさいのです。 これまで何度マクロを作ろうとしたことか。
ついでなので、解答の VBA プログラムを Markdown 変換用マクロとして書き換えてみます。
フレームワークとイベントハンドラの仕組みが十分汎用的なので、そこはそのまま流用し、 イベントハンドラの中身の実装を Markdown 用に書き換えるだけでできそうです。
書いてみると状態管理や文字列操作が単純な分、HTML 版よりだいぶラクでした。
マクロの VBA プログラムは本記事の最後に掲載しています。
使い方は、Excel シートに表を用意し、そのセル範囲を選択した状態でこのマクロを実行します。
すると表の Markdown がクリップボードにコピーされるので、そのまま記事編集画面に張り付けるだけでＯＫです。
|番号 |日付 |価格 |商品名 |グレード | |----:|-----------:|-------:|-------------|:-------:| |1 |2021/1/1 |¥1,000 |商品A |AAA | |2 |2021/1/2 |¥2,000 |商品B |AA | |3 |2020/10/3 |¥3,000 |商品CX |B | |12 |2020/12/24 |¥14,000 |商品D&E |<C |
プレビューすると
| 番号 | 日付 | 価格 | 商品名 | グレード |
|---|---|---|---|---|
| 1 | 2021/1/1 | ¥1,000 | 商品A | AAA |
| 2 | 2021/1/2 | ¥2,000 | 商品B | AA |
| 3 | 2020/10/3 | ¥3,000 | 商品CX | B |
| 12 | 2020/12/24 | ¥14,000 | 商品D&E | <C |
おおっ！
早い！簡単！キレイ！
これは使えますよ。 自分でも驚くほどです。 もっと早く作っておけば・・・
全国1000万のはてなブロガーのみなさん！ ぜひともお試しを！！
最後に、繰り返しになりますが、神髄様にはこのような実用的かつ実践的な課題をご提示いただき誠にありがとうございました。
Option Explicit Private gMD As Object Private firstRow As Long Sub out(ParamArray vals() As Variant) gMD.Add gMD.Count + 1, Join(vals, "") End Sub Sub onInit(conf As Collection) Set gMD = CreateObject("Scripting.Dictionary") End Sub Sub onTerm() End Sub Sub onRangeStart(rng As Range) firstRow = rng.Row End Sub Sub onRangeEnd(rng As Range) End Sub Sub onAreaStart(rng As Range) If rng.Row = firstRow Then Exit Sub Dim c As Range Dim w As Long For Each c In rng.Rows(1).Cells w = Int(c.ColumnWidth) If c.HorizontalAlignment = xlCenter Then out "|", ":", String(w - 2, "-"), ":" ElseIf c.HorizontalAlignment = xlRight Or IsNumeric(c.Value2) Then out "|", String(w - 1, "-"), ":" Else out "|", String(w, "-") End If Next out "|", vbCrLf End Sub Sub onAreaEnd(rng As Range) End Sub Sub onRowStart(rng As Range) End Sub Sub onRowEnd(rng As Range) out "|", vbCrLf End Sub Sub onCell(rng As Range) out "|", rPad(Replace(esc(rng.Text), vbLf, "<br>"), Int(rng.ColumnWidth)) End Sub Private Function rPad(str As String, strWidth As Long, Optional ch As String = " ") As String Dim padLen As Long padLen = strWidth - LenB(StrConv(str, vbFromUnicode)) If padLen > 0 Then rPad = str & String(padLen, Left(ch, 1)) Else rPad = str End If End Function Private Function esc(ByVal txt As String, Optional chars As String = "&<>") As String Dim i As Long Dim ch As String For i = 1 To Len(chars) ch = Mid(chars, i, 1) txt = Replace(txt, ch, "&#" & AscW(ch) & ";") Next esc = txt End Function Sub rangeTraverser(rng As Range, Optional ByVal conf As Collection = Nothing) Dim a As Range Dim r As Range Dim c As Range Call onInit(conf) Call onRangeStart(rng) For Each a In rng.Areas Call onAreaStart(a) For Each r In a.Rows Call onRowStart(r) For Each c In r.Cells Call onCell(c) Next Call onRowEnd(r) Next Call onAreaEnd(a) Next Call onRangeEnd(rng) Call onTerm End Sub Sub セル範囲をMarkdownとしてコピー() If TypeName(Selection) <> "Range" Then Beep: Exit Sub If Selection.Rows.Count = 1 Then Beep: Exit Sub Dim table As Range Dim head As Range Dim body As Range Set table = Selection Set head = table.Resize(1) Set body = Intersect(table, table.Offset(1)) Set table = Range(head.Address & "," & body.Address) Call rangeTraverser(table, Nothing) With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") .SetText Join(gMD.Items(), "") .PutInClipboard End With End Sub
関連記事
セル範囲を HTML ではなく、画像（GIFやPNG）としてはページに張り付けたいときには、以下参考にしてください。 www.shegolab.jp
