VBA 税法条文のカッコ書き部分にオリジナルの書式を適用する。

TwitterでVBA検索してたら面白そうなネタがあったので乗っかり。

税法のカッコ書きの部分にオリジナルの書式を適用するマクロが作りたい様子。

ふむふむと思って調べてみた。

十　同族会社　会社（投資法人を含む。以下この号において同じ。）の株主等（その会社が自己の株式（投資信託及び投資法人に関する法律（昭和二十六年法律第百九十八号）第二条第十四項（定義）に規定する投資口を含む。以下同じ。）又は出資を有する場合のその会社を除く。）の三人以下並びにこれらと政令で定める特殊の関係のある個人及び法人がその会社の発行済株式又は出資（その会社が有する自己の株式又は出資を除く。）の総数又は総額の百分の五十を超える数又は金額の株式又は出資を有する場合その他政令で定める場合におけるその会社をいう。

…お前はLISPかっ。

カッコのネスト深すぎだろう。

ということで、こんな風にネストレベルごとに色分けできるマクロを作ってみた。

作り方

クラスモジュール

クラスモジュールを挿入し、プロパティウィンドウからオブジェクト名をColorfulStringObjectに変更する。

ColorfulStringObjectのコードはこちら。

Private Type ColorText
    TextPart As String
    ColorPart As XlRgbColor
End Type
Private colorTextArray() As ColorText

Private Sub Class_Initialize()
    ReDim colorTextArray(0)
End Sub

Sub AddText(txt As String, Optional col As XlRgbColor = rgbBlack)
    colorTextArray(UBound(colorTextArray)).ColorPart = col
    colorTextArray(UBound(colorTextArray)).TextPart = txt
    ReDim Preserve colorTextArray(UBound(colorTextArray) + 1)
End Sub

Function GetText()
    Dim ret As String
    Dim i As Long
    For i = 0 To UBound(colorTextArray) - 1
        ret = ret & colorTextArray(i).TextPart
    Next
    GetText = ret
End Function

Sub WriteToCell(r As Range)
    r.Value = GetText
    Dim location As Long: location = 1
    For i = 0 To UBound(colorTextArray) - 1
        r.Characters(location, Len(colorTextArray(i).TextPart)) _
            .Font.color = colorTextArray(i).ColorPart
        location = location + Len(colorTextArray(i).TextPart)
    Next
End Sub

標準モジュール

標準モジュールに次のコードを張り付ける。

Function RandomColor() As Long
    Dim r As Byte, g As Byte, b As Byte
    r = WorksheetFunction.RandBetween(0, 255)
    g = WorksheetFunction.RandBetween(0, 255)
    b = WorksheetFunction.RandBetween(0, 255)
    RandomColor = RGB(r, g, b)
End Function

↑カラー設計が面倒なので今回はランダムな色を扱えるように適当な色を返す関数を準備した。

次に、同じ標準モジュールに次のコードを張り付ける。

Sub DrawTheTextOfLawWithColor()
    Const MAX_NEST_DEPTH = 10
    
    '適当に10色追加。実行の度にパレットが変わるので、
    '安定させたくば個別にコレクションに色をAddすべし。
    Dim colorPalette As Collection: Set colorPalette = New Collection
    Dim i As Long
    For i = 1 To MAX_NEST_DEPTH
        colorPalette.Add RandomColor
    Next
    
    '条文はB2セルに書く前提。サンプルなのでゴリゴリハードコーディング。
    Dim targetText As String
    targetText = ThisWorkbook.Worksheets("Sheet1").Range("b2").Value
    
    Dim colorfulString As ColorfulStringObject
    Set colorfulString = New ColorfulStringObject
    Dim j As Long
    
    Dim nestDepth As Long: nestDepth = 1
    
    For j = 1 To Len(targetText)
        Dim ch As String: ch = Mid(targetText, j, 1)
        Dim token As String
        Select Case ch
        Case "（"
            colorfulString.AddText token, colorPalette(nestDepth)
            token = ""
            colorfulString.AddText ch
            nestDepth = nestDepth + 1
        Case "）"
            colorfulString.AddText token, colorPalette(nestDepth)
            token = ""
            colorfulString.AddText ch
            nestDepth = nestDepth - 1
        Case Else
            token = token & ch
        End Select
    Next
    colorfulString.AddText token, colorPalette(nestDepth)
    
    colorfulString.WriteToCell ThisWorkbook.Worksheets("Sheet1").Range("B3")
End Sub

Sheet1のB2から条文を読み取って、Sheet1のB3に色付きで出力させるマクロ完成。
何色になるかは神のみぞ知る。

解説 (5/30追記)

ColorfulStringObjectについて

基本的に他人が作ったクラスは使い方さえ分かれば内部動作に気を配る必要はなく、ソースコードを詳細に読む必要もない。
ということで、ColorfulStringObjectは使い方に絞って説明する。

ColorfulStringObjectは3つのメソッドを持つオブジェクトである。

このうち基本的にはAddTextとWriteToCellを使用する。
サンプルコードはこちら。

Sub HowToUse()
    'オブジェクト使用のための準備
    Dim cso As ColorfulStringObject
    Set cso = New ColorfulStringObject
    
    'オブジェクトにテキストを蓄積
    cso.AddText "ABC", vbRed
    cso.AddText "DEF", vbGreen
    cso.AddText "GHI", vbBlue
    
    'セルに出力
    cso.WriteToCell Range("A1")
End Sub

AddTextメソッドの引数にテキストと色情報を渡すと、次のように内部データ領域に蓄積され、WriteToCellでセルに出力される。

※AddTextで色を省略すると黒色になります。

標準モジュールのDrawTheTextOfLawWithColorについて

まずはカラーパレットを用意するコードから。

    Dim colorPalette As Collection: Set colorPalette = New Collection
    Dim i As Long
    For i = 1 To MAX_NEST_DEPTH
        colorPalette.Add RandomColor
    Next

今回はMAX_NEST_DEPTHを10と定義したので、ランダムで10色作成してコレクションに入れた。
完成したコレクションのイメージはこんな感じ↓

次に、色付けするテキストをtargetText変数に入れる。

    Dim targetText As String
    targetText = ThisWorkbook.Worksheets("Sheet1").Range("b2").Value

次に、ColorfulStringObjectの準備。

    Dim colorfulString As ColorfulStringObject
    Set colorfulString = New ColorfulStringObject

次にネストの深さを示す変数nestDepthを1にしておく。

    Dim nestDepth As Long: nestDepth = 1

このnestDepthは"（"が見つかると増え、"）"が見つかると減る仕組み。
たとえばtargetTextが“あああ（いいい（うう）ええ）お”だとすると、それぞれの文字読み込み時点のnestDepthは次のようになる。

nestDepthの値は、最初に作ったカラーパレットコレクションのインデックスと対応して色を決めている。

今説明したことを行うコードがこちら。

    For j = 1 To Len(targetText)
        Dim ch As String: ch = Mid(targetText, j, 1)
        Dim token As String
        Select Case ch
        Case "（"
            colorfulString.AddText token, colorPalette(nestDepth)
            token = ""
            colorfulString.AddText ch
            nestDepth = nestDepth + 1
        Case "）"
            colorfulString.AddText token, colorPalette(nestDepth)
            token = ""
            colorfulString.AddText ch
            nestDepth = nestDepth - 1
        Case Else
            token = token & ch
        End Select
    Next
    colorfulString.AddText token, colorPalette(nestDepth)

これをざくっと日本語に置き換えるとこんな感じ↓

    For j = 1 To targetTextの文字数まで
        変数chに1文字いれる｡
        Select Case ch
        Case "（"
            colofulStringにtokenを追加し､
            tokenをクリアしてから､
            colofulStringに"（"を追加する。
            そして､nestDepthを増やす｡
        Case "）"
            colofulStringにtokenを追加し､
            tokenをクリアしてから､
            colofulStringに"）"を追加する。
            そして､nestDepthを減らす｡
        Case Else
            変数tokenに文字を継ぎ足す｡
        End Select
    Next
    ループ終了後にcolofulStringに未追加のtokenを追加する｡

※For文の中に変数宣言があるけどこれは気にしない。宣言は1回しか処理されないので外に書いても中に書いても同じ。

あとは、セルに出力するだけ。

    colorfulString.WriteToCell ThisWorkbook.Worksheets("Sheet1").Range("B3")

以上。

参考：過去に書いたColorfulStringObjectの記事

thom.hateblo.jp