見出し画像

【Excel VBA】テーブルヘッダーをひとまとめにする右クリックメニューを作ってみた

kuromaro

目的

テーブルのヘッダー部が複数行で表現されているものをよく見かける。
これは人が見た時の理解のしやすさを重視したものだが、統計処理を行う場合においては煩わしい状態となる。

また、下図のようなセルが結合されていたりするテーブルヘッダーに出会うと、新たにヘッダー部を作り直した方が早いのでは？と思うこともあったりする。

このような表をイメージしてます

セルの結合を解除し、それぞれのテーブルヘッダーをひとつのセルにまとめることができるとかなり便利になると思ったので作ってみた。

完成イメージ

完成コード

とりあえずコードさえ手に入ればいい人は以下のコードを個人用マクロブックの標準モジュールにコピペして、Create_RightClickMenuを一度実行すれば、使えるようになります。
右クリックメニューを元の状態に戻す場合はReset_RightClickMenuを実行してください。

Option Explicit

'**
'* 右クリックメニューを設定
'**
Public Sub Create_RightClickMenu()
    
    'CommandBarタイプの種類を設定
    Dim CMB As Variant: CMB = Array("Cell", "Row", "Column")
    Dim RCM As CommandBar, CBB As CommandBarButton
    
    Dim I As Long
    For I = LBound(CMB) To UBound(CMB)
        
        '右クリックメニュー初期化（重複登録防止）
        Set RCM = Application.CommandBars(CMB(I)): RCM.Reset
        
        '表記ゆれ修正
        Set CBB = RCM.Controls.Add(Before:=1)
        CBB.Caption = "テーブルヘッダーをまとめる (&H)"
        CBB.OnAction = "S_Append_TableHeader"
        
    Next I
    
End Sub

'**
'* 右クリックメニューを初期化
'**
Public Sub Reset_RightClickMenu()

    Dim CMB As Variant: CMB = Array("Cell", "Row", "Column")
    
    Dim I As Long
    For I = LBound(CMB) To UBound(CMB)
        Application.CommandBars(CMB(I)).Reset
    Next I
    
End Sub

'**
'* テーブルヘッダーを行方向に単セルにまとめるプロシージャ
'**
Private Sub S_Append_TableHeader()
    
    Dim inRng As Range: Set inRng = F_Modify_UsedRange(Selection)
    
    Dim singleArea As Range
    For Each singleArea In inRng.Areas '離れたセル範囲を選択していた場合の対策
        
        '行数と列数を取得
        Dim RowNo As Long: RowNo = singleArea.Rows.count
        Dim ColNo As Long: ColNo = singleArea.Columns.count
        
        '結合セル解除処理
        Call S_UnMergeCell_And_FillValues(singleArea)
        
        'テーブルヘッダーを一つのセルにまとめる
        Dim I As Long
        For I = 1 To ColNo
            singleArea.Cells(RowNo, I).Value = F_Join_CellsText(singleArea.Columns(I))
        Next I
        
        '値のクリア、書式初期化
        If RowNo > 1 Then
            With singleArea.Resize(RowNo - 1, ColNo)
                .ClearContents
                .Style = "Normal"
                .Borders.LineStyle = xlNone
            End With
        End If
    
    Next singleArea
    
End Sub

'**
'* データが入力されていない範囲を処理対象から外す関数（高速化）
'* 引数1：inRng{Range型} 処理範囲をRange型で指定
'* 戻り値：{Range型} ワークシートの使用範囲内のみに処理範囲を縮小
'**
Private Function F_Modify_UsedRange(ByVal inRng As Range) As Range
    
    '入力
    Dim ws As Worksheet: Set ws = inRng.Parent
    '処理
    Dim Output As Range: Set Output = Intersect(ws.UsedRange, inRng)
    '出力
    Set F_Modify_UsedRange = Output
    
End Function

'**
'* 選択範囲内の結合セルを解除し、同一値を解除セルすべてに入力するプロシージャ
'**
Private Sub S_UnMergeCell_And_FillValues(ByVal inRng As Range)
    
    Dim Cell As Range
    For Each Cell In inRng.Cells
        If Cell.MergeCells Then
            Set Cell = Cell.MergeArea
            Cell.UnMerge
            Cell.Value = Cell.Resize(1, 1).Value
        End If
    Next Cell
    
End Sub

'**
'* 複数行、列の文字列を結合する
'* 引数１：inRng  {Range型}  処理するセル範囲を指定
'* 引数２：[Mark] {String型} 結合時の区切り文字
'* 戻り値：       {String型} 結合した文字列
'**
Private Function F_Join_CellsText(ByVal inRng As Range, _
                                  Optional Mark As String = "_") As String
    
    Dim dic As Dictionary: Set dic = New Dictionary
    Dim buf As Variant
    
    '表記ゆれの修正、Unique処理
    For Each buf In inRng.Cells
        Dim txt As String: txt = buf.Value
        txt = Replace(txt, vbLf, "")       'セル内改行を解除
        txt = StrConv(txt, vbNarrow)       'すべて半角文字に変換
        txt = WorksheetFunction.Trim(txt)  '前後の空白、2つ以上連続の空白を1つに統一
        txt = F_Conv_HalfKana_To_Full(txt) '半角カタカナを全角カタカナに変換
        If Not dic.Exists(txt) Then dic.Add txt, Null
    Next buf
    
    'Unique処理したkeysを一行にまとめる
    Dim Output As String: Output = Join(dic.Keys, Mark)
    
    '出力
    F_Join_CellsText = Output
    
End Function

'**
'* 半角カタカナを全角に変換する関数
'* 引数1：inTxt{String型} 変換したい文字列を指定
'* 戻り値：{String型} 変換後の文字列
'**
Private Function F_Conv_HalfKana_To_Full(ByVal inTxt As String) As String

    '処理
    Dim I As Long
    For I = 1 To Len(inTxt)
        Dim char As String: char = Mid(inTxt, I, 1)
        Dim charCode As Long: charCode = AscW(char)
        
        Dim tmpTxt As String
        Dim result As String
        If charCode >= &HFF61 And charCode <= &HFF9F Then
            tmpTxt = tmpTxt & char
        Else
            If tmpTxt <> "" Then
                result = result & StrConv(tmpTxt, vbWide)
                tmpTxt = ""
            End If
            result = result & char
        End If
    Next I
 
    If tmpTxt <> "" Then result = result & StrConv(tmpTxt, vbWide)
    
    '出力
    F_Conv_HalfKana_To_Full = result
    
End Function

操作方法

テーブルヘッダーのセル範囲を、マウスやキーボードで選択する。
選択したセル範囲上で右クリックをして表示されたメニューから「テーブルヘッダーをまとめる」を選択する。
これだけで、テーブルヘッダーがひとつのセルにまとまります。

なお、うまく動作しない場合は、「ツール」→「参照設定」を開き、「Microsoft Scripting Runtime」の左側にチェックを入れてOKボタンで確定してください。

コード解説

一見複雑そうにみえるコードですが、ひとつひとつ読み解いていけば単純なコードの繰り返しであることがわかります。
プログラムを日本語にして書いてみると以下のようになります。

やっていること

  1. 結合セルを解除し、同一値を解除したセル範囲に貼り付けする

  2. 表記ゆれを修正する

  3. Dictionary型を使いUnique処理する（重複ワードを除外する）

  4. Unique処理したKeyをJoin関数でまとめる

  5. まとめた値をセルに転記する

  6. まとめた値より上の行のタイトルを削除し、書式設定を初期化する

上記1～6の操作を順番に書いていくことでコードが完成します。

メインプロシージャ

'**
'* テーブルヘッダーを行方向に単セルにまとめるプロシージャ
'**
Private Sub S_Append_TableHeader()
    
    Dim inRng As Range: Set inRng = F_Modify_UsedRange(Selection)
    
    Dim singleArea As Range
    For Each singleArea In inRng.Areas '離れたセル範囲を選択していた場合の対策
        
        '行数と列数を取得
        Dim RowNo As Long: RowNo = singleArea.Rows.count
        Dim ColNo As Long: ColNo = singleArea.Columns.count
        
        '1. 結合セル解除処理
        Call S_UnMergeCell_And_FillValues(singleArea)
        
        '2～5. テーブルヘッダーを一つのセルにまとめる
        Dim I As Long
        For I = 1 To ColNo
            singleArea.Cells(RowNo, I).Value = F_Join_CellsText(singleArea.Columns(I))
        Next I
        
        '6. 値のクリア、書式初期化
        If RowNo > 1 Then
            With singleArea.Resize(RowNo - 1, ColNo)
                .ClearContents
                .Style = "Normal"
                .Borders.LineStyle = xlNone
            End With
        End If
    
    Next singleArea
    
End Sub

1. 結合セル解除処理

'**
'* 選択範囲内の結合セルを解除し、同一値を解除セルすべてに入力するプロシージャ
'**
Private Sub S_UnMergeCell_And_FillValues(ByVal inRng As Range)
    
    Dim Cell As Range
    For Each Cell In inRng.Cells
        If Cell.MergeCells Then
            Set Cell = Cell.MergeArea
            Cell.UnMerge
            Cell.Value = Cell.Resize(1, 1).Value
        End If
    Next Cell
    
End Sub

詳細は以下リンクを参照。

2～4. テーブルヘッダーを一つのセルにまとめる

メインプロシージャに書くと、コードが読みにくくなるため、F_Join_CellsText関数としています。

'**
'* 複数行、列の文字列を結合する
'* 引数１：inRng  {Range型}  処理するセル範囲を指定
'* 引数２：[Mark] {String型} 結合時の区切り文字
'* 戻り値：       {String型} 結合した文字列
'**
Private Function F_Join_CellsText(ByVal inRng As Range, _
                                  Optional Mark As String = "_") As String
    
    Dim dic As Dictionary: Set dic = New Dictionary
    Dim buf As Variant
    
    '表記ゆれの修正、Unique処理
    For Each buf In inRng.Cells
        Dim txt As String: txt = buf.Value
        txt = Replace(txt, vbLf, "")       'セル内改行を解除
        txt = StrConv(txt, vbNarrow)       'すべて半角文字に変換
        txt = WorksheetFunction.Trim(txt)  '前後の空白、2つ以上連続の空白を1つに統一
        txt = F_Conv_HalfKana_To_Full(txt) '半角カタカナを全角カタカナに変換
        If Not dic.Exists(txt) Then dic.Add txt, Null
    Next buf
    
    'Unique処理したkeysを一行にまとめる
    Dim Output As String: Output = Join(dic.Keys, Mark)
    
    '出力
    F_Join_CellsText = Output
    
End Function

2. 表記ゆれを修正

表記ゆれがあると、同じことでも違うものとして判別されてしまうため、次のUnique処理する前に、修正しておきます。

For Each～Next文のtxt変数を指定している部分が該当箇所になります。
セル内改行を解除はReplace関数を、すべて半角文字に変換はStrConv関数を、前後の空白を削除、2つ以上の連続空白を1つの空白に変えるのはWorksheet関数のTrim関数を使って修正しています。
半角カタカナを全角カタカナに変換するコードは以下リンクを参照。

3. Dictionary型を使いUnique処理する

For Each～Next文の最終行にある以下のコードで重複しているかを判定して追記する、しないを分岐処理しています。

If Not dic.Exists(txt) Then dic.Add txt, Null

4. Unique処理したKeyをJoin関数でまとめる

Join関数を使うことでDictionary型のKeyすべてを一括でひとまとめにできます。Markは区切り文字を指定します。

Dim Output As String: Output = Join(dic.Keys, Mark)

5. まとめた値をセルに転記する

メインプロシージャのFor～Next文の中に入っている操作になります。
singleArea.Cells(RowNo, I)に2～4.で処理した文字列を格納します。
RowNoはsingleAreaの最終行になる。

Dim I As Long
For I = 1 To ColNo
    singleArea.Cells(RowNo, I).Value = F_Join_CellsText(singleArea.Columns(I))
Next I

6. 値のクリア、書式初期化

ヘッダー最終行より上の行の値を消去し、書式を標準に戻し、罫線を消す操作をしています。
一行しか選択されていない場合にIF文を使い、エラーを回避しています。

'値のクリア、書式初期化
If RowNo > 1 Then
    With singleArea.Resize(RowNo - 1, ColNo)
        .ClearContents
        .Style = "Normal"
        .Borders.LineStyle = xlNone
    End With
End If

右クリックメニュー

右クリックメニューの説明は、以下記事を参考にしてください。

以上、最後までお読みいただきありがとうございました。


いいなと思ったら応援しよう！