VBAでセルの結合～フィルターで正しい抽出ができる方法

2021-11-08

同じデータでセルの結合と解除を頻繁に行うことがあり作成しました。

セル結合だけではなく、結合後にフィルターで正しい抽出結果になるようにします。

参考

セルを結合したデータは、再編集や他のシステムへ取り込む場合非常に不便です。しかしセルの結合をしないように周知することは非常に困難。それなら、結合セルがあっても簡単に解除したり、結合したりする仕組を作った方が早いです。

結合とフィルター設定

A列のデータを結合する例です。

結合例

A列にあるデータをB列にコピーしておきます。

マクロ実行後の画面です。B列のデータで同じ県名のセルを結合します。

「秋田県」を抽出した例です。

サンプルコード

Sub sample()
    Application.DisplayAlerts = False
    Dim i As Long, s As Long, e As Long
    s = 2
    For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
        If Cells(i, 2) <> Cells(i + 1, 2) Then
            e = i
            If e - s > 0 Then
                Range(Cells(s, 2), Cells(e, 2)).Merge
                Range(Cells(s, 1), Cells(e, 1)).Copy
                Range(Cells(s, 2), Cells(e, 2)).PasteSpecial Paste:=xlPasteFormulas
            End If
            s = e + 1
        End If
    Next i
    Application.CutCopyMode = False
    Application.DisplayAlerts = True
End Sub

2行目：メッセージを表示しません。これを入れないと結合の度に次のようながメッセージが表示されます。

8行目：同じ文字が入力されているセルが2個以上の時にセルの結合を実行します
9行目：セルの結合
10～11行目：形式を選択して貼り付けの「数式」
16行目：コピーモード解除

セルの解除の例です。

Range("B2:B11").MergeCells = False

結合とフィルター設定・応用

A列とB列の結合例です。

結合例

サンプルコード

Sub sample3()
    Dim motoC As Long, sakiC As Long
    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
    End With
    
    Range("A1").CurrentRegion.Copy Range("D1")
    
    motoC = 4
    sakiC = 1
    
    Call cMerge(motoC, sakiC)
    
    motoC = 5
    sakiC = 2
    Call cMerge(motoC, sakiC)
    
    Range("D1").CurrentRegion.ClearContents
    
    With Application
        .CutCopyMode = False
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
End Sub
Private Sub cMerge(mC, sC)
    Dim i As Long, s As Long, e As Long
    s = 2
    For i = 2 To Cells(Rows.Count, mC).End(xlUp).Row
        If Cells(i, mC) <> Cells(i + 1, mC) Then
            e = i
            If e - s > 0 Then
                Range(Cells(s, sC), Cells(e, sC)).Merge
                Range(Cells(s, mC), Cells(e, mC)).Copy
                Range(Cells(s, sC), Cells(e, sC)).PasteSpecial Paste:=xlPasteFormulas
            End If
            s = e + 1
        End If
    Next i
End Sub

8行目実行後の画面です。

D列～E列について：コピーして「数式」を貼り付けのためのデータです。マクロ終了前に消します。