ゆるおたノート

Tomorrow is another day.

【Excel VBA】一発でテーブルの変換とスタイル変更をしたい

Excelでデータを管理する時は、テーブル機能が便利ですよね。
1行だけ関数を設定すれば、行が増えても自動で式を補完してくれたり*1

最近はGoogle SpreadSheetに触る頻度も上がっていますが、
クラウドでデータ保管することにもまだ不安があったりするので、
完全にExcelから卒業するにはもうちょっと時間がかかりそうです。

ところが、テーブル化したはいいものの、Excelに元からある
テーブルスタイルがちょっと使いづらい、ということがあります。

やたらカラフルだったり、しましま無しを選ぶと「まっさら」
だったり…極端だなぁ…
これでもOKではあるけど、「もっと別のデザインを使いたい」
こともありますよね。

VBAerとしてはこれを毎回手動で設定するのも面倒なので、
今回は、マクロ1つで好みのスタイルでテーブル化出来るよう
に考えていきたいと思います。

目標

実現したいこと

今考えているのは、以下の4つ。

  1. 選択範囲をテーブル化
  2. しましまの無い、罫線・見出しだけのテーブルスタイル(後述)を作る
  3. ブックの既定のスタイルに登録する
  4. (もし出来れば)後々色は自由に選べるようにしたい

少しずつやっていきたいと思います。
4つめは必要になった時でいいかもしれませんが…

ちなみに、新規作成のブックで使えるようにしたいだけであれば、
3.まで行って、テンプレ(.xlsx)で作ってシステムに保存する
手もあります。ご参考まで…

完成イメージ

こんなテーブルを作ります。罫線もうっすらと。

完成イメージ

何の表か気になる方だけこちらへ…→*2

マクロ

自動記録の流用

テーブル関係の設定で使うオブジェクトが分からなかったので、
まずは自動記録の力を借りて、Selectionを消したり
変数を使ったりして軽く整理してみました。

あわせて、メッセージや名前を入れるInputBox関数を少し追加しています。

コード(途中経過)

※かなり長いので、プロシージャごとに分割して掲載します。

1. メイン

コレが1番長いです。

Public Sub setTable()

    Dim myBook As Workbook: Set myBook = Nothing
    Dim thisSheet As Worksheet: Set thisSheet = Nothing
    Set myBook = ActiveWorkbook
    Set thisSheet = myBook.ActiveSheet

    '実行準備
    Call prepareAgainstRuntimeError(thisSheet)
   
    Dim newTable As ListObject
    Set newTable = convertRangeIntoTable(thisSheet)
    
    'スタイルを作成
    If MsgBox("テーブルのスタイルも新規作成してよろしいですか?" & vbCrLf & _
              "適用予定のスタイル名:" & newTable.TableStyle, vbYesNo) = vbYes Then
        Dim newStyleName As String
        newStyleName = createStyle(myBook)
        
        newTable.TableStyle = newStyleName 'スタイルを適用
        
        '既定のスタイルに設定しておく
        myBook.DefaultTableStyle = newStyleName
    End If
    
    MsgBox "現在のテーブル・スタイル:" & newTable.TableStyle
        
    '後処理
    thisSheet.Cells(1, 1).Select
    
    MsgBox "テーブルに変換しました。"
    
    If MsgBox("最後に、このブックを上書き保存してよろしいですか?", vbYesNo) = vbNo Then
        MsgBox "承知しました。保存は中止します。"
        Exit Sub
    End If
        
    myBook.Save
    MsgBox "保存しました。"
    
    Set thisSheet = Nothing
    Set myBook = Nothing
       
End Sub
2. 一応エラー対策
2-1 ユーザーに許可とってからその2へ
Private Sub prepareAgainstRuntimeError(ByRef targetSheet As Worksheet)

    With targetSheet
        .Cells(1, 1).Activate
        
        If MsgBox("選択しているシート上のテーブルを、すべて解除してもよろしいですか?" & vbCrLf & _
                  "※選択範囲でテーブルが有効になっていると、この機能が使えません。", vbYesNo) = vbYes Then
        
            Call convertTablesIntoRange(targetSheet)
        End If
        
        If .AutoFilterMode = True Then
            .AutoFilterMode = False
        End If
    End With

End Sub
2-2 テーブルがあったら解除する

「範囲が被ったらエラー」なので、エラーが出てから
On Errorで飛んできた方が良いかも。

Private Sub convertTablesIntoRange(ByRef targetSheet As Worksheet)

        Dim list As ListObject
        For Each list In targetSheet.ListObjects
            list.Unlist
        Next list

End Sub
3. テーブルに変換
Private Function convertRangeIntoTable(ByVal targetSheet As Worksheet) As ListObject

    Dim newTableRange As Range
    Set newTableRange = targetSheet.Cells(1, 1).CurrentRegion
    
    Dim newList As ListObject
    Set newList = targetSheet.ListObjects.Add(xlSrcRange, newTableRange, , xlYes)
    
    Dim newTableName As String
    newTableName = InputBox("新規作成するテーブルの名前を入力してください。")
    newList.Name = newTableName
    
    Set convertRangeIntoTable = newList

End Function
4. テーブルスタイルを新規作成
4-1 テーブル全体と見出し行で処理を分ける
Private Function createStyle(ByVal targetBook As Workbook) As String

    Dim newStyle As TableStyle
    Dim newName As String
    newName = InputBox("続いて、新しいスタイルの名前を入力してください。")
    Set newStyle = targetBook.TableStyles.Add(newName)
       
   '▼テーブル全体
    Dim black As Long: black = RGB(0, 0, 0)
    Dim lightGray As Long: lightGray = RGB(208, 206, 206)
    
    Call setWholeStyle(newStyle, black, lightGray)
   
   '▼見出し行(HeaderRow)
    Call setHearderStyle(newStyle)
   
    createStyle = newName

    Set newStyle = Nothing

End Function
4-2 「テーブル全体」のスタイルを設定
Private Sub setWholeStyle(ByRef targetStyle As Variant, _
                          Optional ByVal outerLineColor As Long =  0, _
                          Optional ByVal innerLineColor As Long = 13553360)

    Dim wholeTableElements As Variant
    Set wholeTableElements = targetStyle.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
4-3 罫線を付ける
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
4-4 「見出し行」のスタイルを設定
Private Sub setHearderStyle(ByRef targetStyle As Variant)

   Dim headerRowElements As Variant
   Set headerRowElements = targetStyle.tableStyleElements(xlHeaderRow)
   
   Dim deepBlue As Long: deepBlue = RGB(0, 32, 96)
   Dim white As Long: white = RGB(255, 255, 255)

    With headerRowElements
        
        .Interior.color = deepBlue
        
        With .Font
            .Bold = True
            .color = white
        End With
    
    End With

End Sub

感想と気づいたこと

コードが汚い…

For文やプロシージャ化しつつ少し整理してみましたが、
上から順に書き換えただけなのでなんだか流れが分かりづらい
ですよね…
もうちょっとキレイなコードに出来ないものかと。

テーブル作成してから名前変えてる*3し、上の方の
「スタイルを作成」の分岐も独立できそう。

何よりメインのプロシージャが長い!
操作が多いから仕方ないですが、1画面で全体像が見えないので
もうちょっと短くしたいですね。

テーブルスタイルのオブジェクト

スタイルの変更にはこの辺をいじると良さそうです。

  • TableStyleElementsコレクション / TableStyleElementオブジェクト
  • TableStyleオブジェクト

Addメソッドの戻り値

この記事を書きながら調べていて分かったのですが、
ListObjects.Add()するとテーブル(ListObject)ではなく
テーブル名が返ってくる
そうです。

と少し矛盾しますが)これで既定の名前を使うかどうか
の選択肢が作れそうです。

<2019/05/14追記>
こちらは筆者の勘違いでした!大変失礼いたしました…
普通にListObjectオブジェクトが返ってきます。

これ使える…?

保存先のダイアログ

正直まだダイアログの使い方があまり分かってないのですが苦笑、
実践の方が身に付くはず、ということで…

コードでは確認無しに既存のパスに上書きしてますが、
保存場所もダイアログで選べる方が良さそうです。

クラス

正直まだクラスの使い方があまり(以下略)

setWholeStyleプロシージャ以下は共通の処理なので
色や変更する場所あたりを渡せばメインモジュールは
少しスッキリするんではないかと…?(推測)

ユーザーフォーム

正直まだユー(以下略)

選択肢や名前の入力が多いので、最初に一気に選べた方が
ウザくないし処理もぶつ切りにならなくて良いかもしれません。

改善点がいっぱい。

書けば書くほど気になる点がガンガン出てくるのですが、
全部実装できるかは全く自信がありません…
最近偉そうに書いたばっかりですが…

1つずつ学んでいきます。時間だけなら今はたっぷりあるので…!

このシリーズについて

テーブルの変換とテーブルスタイルの新規作成をマクロ1発で
使えるように考えています。主に自分向け。

もし間違いやヘンなところ等ありましたら、コメント欄やTwitter
ご指摘いただけたら嬉しいです。

次回

yuru-wota.hateblo.jp

連載目次

  1. (本記事)【Excel VBA】一発でテーブルの変換とスタイル変更をしたい - ゆるオタクのすすめ
  2. 【Excel VBA】テーブル変換とスタイル変更 - 処理の流れを整理してみる - ゆるオタクのすすめ
  3. 【Excel VBA】テーブル変換とスタイル変更 - テーブル変換するところまで標準モジュールで書いてみる - ゆるオタクのすすめ
  4. 【Excel VBA】テーブル変換とスタイル変更 - 標準モジュールでスタイルを新規作成する - ゆるオタクのすすめ
  5. https://yuru-wota.hateblo.jp/entry/VBA/overwrite-save-or-new

注釈

*1: 書いたことは無いけど、たぶんイベントトリガーでGASを動かせば同じようなことはできる気がしますね。

*2: 8月にメジャーデビュー予定の「BEYOOOOONDS」です。
"びよーんず"と読みます。

まだ公式MVが無いのでこちら↓を…
12分耐久ミュージカル風の奇曲です。1曲目のピコピコ8bitが楽しい。
www.youtube.com

*3: これは自動記録あるあるですね。