今日を乗り切るExcel研究所

Excel に働かされていませんか

【VBA】Excel で作成した表を HTML に変換したい【100本ノック】

今回もエクセルの神髄様の Twitter 企画「VBA100本ノック」の便乗記事です。 今回はその94本目をやります。 ついでにはてなブログで使える Markdown 表組へ変換するマクロも作ります。

お題:VBA100本ノック 94本目:表範囲からHTMLのtableタグを作成

方針

今回のお題は本ブログでもいつかやろうとは思っていたネタでした。

このマクロを作れば早く終われた仕事が何回かあったのですが、結局は後回しで手付かず仕舞いでした。

今回踏ん切りをつける機会をいただいて、エクセルの神髄様には感謝申し上げます。

さて、設計的には基本的にセル範囲の行と列のループの中で 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 = "&nbsp;"
    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 シートに表を用意し、そのセル範囲を選択した状態でこのマクロを実行します。

f:id:shego:20210227221301p:plain

すると表の Markdown がクリップボードにコピーされるので、そのまま記事編集画面に張り付けるだけでOKです。

|番号 |日付        |価格    |商品名       |グレード |
|----:|-----------:|-------:|-------------|:-------:|
|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&#38;E  |&#60;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

www.shegolab.jp