【Excel VBA】テーブル変換とスタイル変更～標準モジュールでスタイルを新規作成する～

VBAでテーブル化と好みのテーブルスタイル設定のマクロ化に取り組んでいます。

前回は、先日のフローチャートをもとに、テーブル化までコードを書きました。
【Excel VBA】テーブル変換とスタイル変更～テーブル変換するところまで標準モジュールで書いてみる～ - ゆるおたノート

今回も引き続きテーブルのスタイルを指定するところまで書いてみます。

進捗
コード
- Module1: ConvertIntoTable
- Module3: createTableStyle
後記
このシリーズについて
- 次回
- 連載目次
注釈

進捗

挑戦!!と付いているモノが本記事のテーマです。

Clear!!~~選択範囲をテーブル化~~
- Clear!!~~指定範囲にテーブルがあると「実行時エラー」が発生するので、エラーが出てからOn Errorで「テーブルの解除」に進んだ方が良いかも。~~
- NG~~ListObject.Addメソッドの戻り値で既定の名前も選択可。~~
挑戦!!しましまの無い、罫線・見出しだけのテーブルスタイルを作る
- 挑戦!!テーブルスタイル関連のオブジェクト
  - 挑戦!!TableStyleオブジェクト
  - 挑戦!!TableStyleElementオブジェクト / TableStyleElementsコレクション
挑戦!!ブックの既定のスタイルに登録する
保存先をダイアログで指定
クラスで共通処理を分離
ユーザーフォームで操作簡略化
- （もし出来れば）色は自由に選べるようにしたい

<2019/05/17追記>
3. のラベルが抜けていたので修正しました。

コード

Module1: ConvertIntoTable

Mainプロシージャには、Call setTableStyle～の1行だけ追加になりました。

また、「選択範囲」の反映方法を調整しています。
この場合、以下のような挙動になります。

表の一部分のみ選択されている場合は、表全体*1を取得しテーブル化。
表が複数含まれている場合は、左上の表のみテーブル化。

Public Sub Main()

    '念のため変数に入れておく
    Dim myRange As Range
    Set myRange = Selection.CurrentRegion '※選択範囲のうち、左上にある表をターゲットとする

    Dim myBook As Workbook:    Set myBook = ActiveWorkbook
    Dim mySheet As Worksheet: Set mySheet = myBook.ActiveSheet

    'エラー対策
    If hasListObjectOnSelection(myRange) = False Then Exit Sub

    Dim listObj As ListObject
    Set listObj = convertRangeIntoTable(mySheet, myRange)

    Set myRange = Nothing

    '▼追加
    Call setTableStyle(myBook, listObj)


    '～ブックを保存する処理～


    MsgBox "処理が完了しました。"

End Sub

長くなるので、特に変更のないModule2は省略しまして…

Module3: createTableStyle

このモジュールのメイン

初期のコードにあったMainプロシージャから、一連の処理を丸ごと独立したモジュールとしました。
Do While ~ Loopの部分をさらにプロシージャ化できないかな…

今回はクラス構文は使っていませんが、プログラミング用語的には「単一責任原則」*2と言うようです。

Option Explicit
Option Private Module

Public Sub setTableStyle(ByRef targetBook As Workbook, _
                         ByRef targetListObj As ListObject)

    If isOkToCreateTableStyle = False Then Exit Sub

    Dim defaultStyleName As String
    defaultStyleName = targetListObj.TableStyle
    Dim newStyleName As String
    newStyleName = inputStyleName(defaultStyleName)

    Do While (newStyleName = defaultStyleName) _
        Or isExistStyleName(targetBook, newStyleName)

        If MsgBox("指定の名前は既に存在しています。こちらを適用しますか？", vbYesNo) = vbYes Then
        MsgBox "既定のテーブルスタイルを適用します。"
        Exit Sub 'スタイルは変更せずに終了
        End If

        MsgBox "お手数ですが、もう1度スタイルの名前を登録して下さい。"
        newStyleName = inputStyleName(defaultStyleName)

    Loop

    Dim newStyle As TableStyle
    Set newStyle = targetBook.TableStyles.Add(newStyleName)
    Call changeTableDesign(newStyle)

    '既定のスタイルに設定しておく
    targetBook.DefaultTableStyle = newStyleName

    targetListObj.TableStyle = newStyle

End Sub

一旦ユーザーに意向確認

不要なら今回の処理はすべて飛ばします。

Private Function isOkToCreateTableStyle()

    If MsgBox("テーブルのスタイルも新規作成しますか？", vbYesNo) = vbNo Then
        MsgBox "承知しました。スタイルの作成は中止します。"
        isOkToCreateTableStyle = False
        Exit Function
    End If

    isOkToCreateTableStyle = True

End Function

名前を入力してもらう

やっていることは初期のコードと同じなので、説明は割愛します。

Private Function inputStyleName(ByRef defaultStyleName As String) As String

    Dim m As String
    m = "新しいスタイルの名前を入力してください" & vbCrLf
    m = m & "既定の名前：" & defaultStyleName

    Dim newStyleName As String
    newStyleName = InputBox(Prompt:=m, _
                            Default:=defaultStyleName)

    inputStyleName = newStyleName

End Function

ところで、昨日もテーブル名の設定で触れた「文字列の入力問題」について、Twitterにて下記のご意見をいただきました。

テーブルの1行目の左端にはインデックスが入っているとルールのお約束があって、そのセルに「〇〇ID」と項目名があれば、自動でテーブル名が「〇〇」になるとかもできそうですね。
— 佐藤嘉浩(Excelの魔法使い・スピルのひと)@仙台 (@yosatonet) 2019年5月14日

ご意見ありがとうございます！
スタイル名の入力と合わせて、シート上で設定出来るようにすればユーザーにとっても使いやすそうですね。

ユーザーフォームも作成不要・~~学習も不要~~で一石三鳥！

既定の名前と見比べる

スタイルの名前で既存のものと被ってしまうと、新規作成する時にエラーになります。
対策として、事前にチェックしておきます。

Private Function isExistStyleName(ByRef targetBook As Workbook, _
                                  ByVal newStyleName As String) As Boolean

    Dim i As Long
    For i = 1 To targetBook.TableStyles.count
        If newStyleName = targetBook.TableStyles(i).Name Then
            isExistStyleName = True
            Exit Function
        End If
    Next

    isExistStyleName = False

End Function

ただし、TableStylesコレクションはインデックスが「0始まり」ではなく「1始まり」みたいなんですよね…不思議…

<2020/10/21追記>
これはコレクション型の仕様だそうです…やっぱり不思議。

コレクションのメンバーの位置を式で指定します。数式の場合、index には、1 以上からコレクションの Count プロパティ値までの数値を指定します。

Item メソッド (Visual Basic for Applications) | Microsoft Docs

テーブルスタイルの内容を変更

TableStyles.Add()を同モジュールのプロシージャ1つ目に移動したことで初期コードと役割が変わったので、プロシージャ名を変更しました。

引き数は一部省略も可能（後述）ですが、読みやすさのために今回は省略せずに書いています。

Private Sub changeTableDesign(ByRef tableStyleObj As Variant)

    'テーブル全体（WholeStyle）
    Dim black As Long:         black = RGB(0, 0, 0)
    Dim lightGray As Long: lightGray = RGB(208, 206, 206)

    Call setWholeStyle(tableStyleObj, black, lightGray)

    '見出し行（HeaderRowStyle）
    Dim deepBlue As Long: deepBlue = RGB(0, 32, 96)
    Dim white As Long:       white = RGB(255, 255, 255)

    Call setHeaderStyle(tableStyleObj, deepBlue, white, True)

End Sub

テーブルの罫線を設定

お好みですが、罫線の色についてあらかじめ既定値を決めます。
私はイミディエイトウィンドウでRGB()関数を使って数値を確認してみました。
（今回は↑のコードと同じ値としています）

? RGB(0, 0, 0) 'black
0

? RGB(208, 206, 206) 'lightGray
13553360

こちら↑を基準にOptionalキーワードで既定値を設定。
これで、引数を省略しても動くようになります。

便宜的に改行も足してみましたが、元の方が読みやすかったかも…？

Private Sub setWholeStyle(ByRef tableStyleObj As Variant, _
                          Optional ByVal outerLineColor As Long = 0, _
                          Optional ByVal innerLineColor As Long = 13553360)

    Dim wholeTableElements As Variant
    Set wholeTableElements = tableStyleObj.TableStyleElements(xlWholeTable)

    Dim outerLineConstants As Variant
    outerLineConstants = Array(xlEdgeTop, _
                               xlEdgeBottom, _
                               xlEdgeLeft, _
                               xlEdgeRight _
                               )

    Call setLines(wholeTableElements, _
                  outerLineConstants, _
                  outerLineColor, _
                  xlContinuous, _
                  xlMedium _
                  )

    Dim innerLineConstants As Variant
    innerLineConstants = Array(xlInsideVertical, _
                               xlInsideHorizontal _
                               )

    Call setLines(wholeTableElements, _
                  innerLineConstants, _
                  innerLineColor, _
                  xlContinuous, _
                  xlThin _
                  )

End Sub

罫線を付ける

既定値に指定しているxlContinuousはいわゆる「実線」、xlThinは「Excelで初期設定されている太さ」を表します。

Private Sub setLines(ByRef StyleElements As Variant, _
                     ByRef linePositions As Variant, _
                     ByVal targetColor As Long, _
                     Optional ByVal lineStyle As Long = xlContinuous, _
                     Optional ByVal thickness As Long = xlThin)

    With StyleElements
        Dim i As Long
        For i = 0 To UBound(linePositions)
            With .Borders(linePositions(i))
                .Color = targetColor
                .lineStyle = lineStyle
                .Weight = thickness
            End With
        Next i
    End With

End Sub

見出し行の色を設定

罫線と同様、イミディエイトウィンドウで確認して既定値を設定しています。

? RGB(0, 32, 96) 'deepBlue
16777215

? RGB(255, 255, 255) 'white
6299648

色や.Boldプロパティはお好みで変更可ということで、こちらもOptionalとしました。

Private Sub setHeaderStyle(ByRef tableStyleObj As Variant, _
                           Optional ByVal interiorColor As Long = 16777215, _
                           Optional ByVal fontColor As Long = 6299648, _
                           Optional ByVal isBold As Boolean = True)

   Dim headerRowElements As Variant
   Set headerRowElements = tableStyleObj.TableStyleElements(xlHeaderRow)

    With headerRowElements

        .Interior.Color = interiorColor

        With .Font
            .Color = fontColor
            .Bold = isBold
        End With

    End With

End Sub