このサイトはCocoonを使っています。現在「ミックスブルー [作者: y.hiroaki氏]」スキンを適用中です(^^)/

Excel VBA 連続した同じ値のセル範囲を自動で結合する

スポンサーリンク

この記事では、連続した値のセル範囲を自動で調べて結合するVBAマクロのコードを紹介しています。

くるみこ
くるみこ

列(タテ)方向または行(ヨコ)方向に隣接するセルが同じ値だった場合に、自動で結合しちゃうコードを検討してみましょう(^^)/

イメージとしては、セルを順番に比較していく感じでしょうか?
よろしくお願いしますm(_ _)m

【この記事でわかること
・縦方向または横方向の隣接するセル同士が同じなら自動でセルを結合する方法

・UnionメソッドとOffsetを使ったセル範囲の操作方法

前回記事のおさらいは、下のカードをクリックすれば開きます(^^ゞ

くるみこ
くるみこ

前回記事は、セル範囲結合の「結合機能向上編」です。複数選択や「列」方向の結合にも対応するように調整している記事です。是非覗いてみてね(^^)/

スポンサーリンク

同じデータが連続しているセルを結合させる

Applocation.UnionメソッドRange.Offsetプロパティを使ってセル範囲を操作します。
・さっそくコードを紹介します。

指定「列」で同じ値が連続しているセル範囲を結合するコード

'指定列で同じデータが連続した場合そのセル範囲を結合する
Sub MergeCellsCol()
    Dim rng As Range
    Dim tgr As Long
    Dim sr As Long, er As Long, col As Long
    'Application.InputBoxで列を指定できるようにする
    On Error Resume Next
    Set rng = Application.InputBox( _
        Prompt:="対象列のセル範囲を選択指定するか" & vbCrLf & _
        "先頭セルを選択してください!", Title:="対象セル選択", Type:=8)
    On Error GoTo 0
    If rng Is Nothing Then Exit Sub
    '選択された先頭セルの行と列の番号を取得します
    sr = rng.Row
    col = rng.Column
    'セル選択状態を判定して最終行を取得します
    If rng.Count = 1 Then
        er = Cells(Rows.Count, col).End(xlUp).Row '先頭だけ選択の場合
    Else
        er = sr + rng.Count - 1 '範囲で選択している場合
    End If
    Set rng = Cells(sr, col)    '先頭セルをRangeオブジェクト変数に代入
    
    For tgr = sr To er - 1      '最終行の一つ手前までループ処理
        With Cells(tgr, col)
            '次のセルとセルの値を比較して同じ間はセル範囲を広げます
            If .Value = .Offset(1, 0).Value Then
                Set rng = Union(rng, .Offset(1, 0))
            Else
            '値が違うセルが出現したら広げていた範囲を結合します
                Application.DisplayAlerts = False
                rng.Merge
            '    rng.HorizontalAlignment = xlHAlignCenter '横中央
                rng.VerticalAlignment = xlVAlignCenter   '縦中央
                Application.DisplayAlerts = True
                Set rng = .Offset(1, 0)     '次のセルをRange変数に代入
            End If
        End With
    Next
    '範囲の一番最後が前のセルと同じだった場合の結合処理
    If rng.Count > 1 Then 'Range変数が複数だった場合結合します
        Application.DisplayAlerts = False
        rng.Merge
    '    rng.HorizontalAlignment = xlHAlignCenter '横中央
        rng.VerticalAlignment = xlVAlignCenter   '縦中央
        Application.DisplayAlerts = True
    End If
End Sub

コード内容を補足解説します

・コード内にコメントを入れているので参照してください。以下は補足説明です。
・7~12行目は、おなじみApplication.InputBoxの処理です。「先頭セル」か「セル範囲」のどちらかの選択を促しています。
・17~21行目で、対象範囲の最終行番号を確定させています。
・24行目からループ処理開始。最終は最終行番号の一つ手前までにしています。
★その理由は、選択範囲の次のセルが最終セルと同じだった場合、範囲の下のセルも結合してしまうのを防止するためです。
・27行目で、対象セルとその下のセル「.Offset(1, 0)」の値を比較しています。
・28行目、同一だった場合、Set rng = Union(rng, .Offset(1, 0)) でRange変数の範囲を拡張してセットし直しています。
・31~35行目は、値の違うセルが出現した場合、それまでのセル範囲でセル結合を実行しています。値の位置を「縦中央」に設定しています。
41~46行目、最後のセルが前のセルと同一だった場合、ループ内で結合処理が完結していないのでその処理をここで行っています。Range変数が複数かどうか判定して実行します。

指定「列」で同じ値が連続しているセル範囲を結合するコード

・先ほどのコードを「行」ヨコ方向のバージョンに変更して利用できます。

'指定行で同じデータが連続した場合そのセル範囲を結合する
Sub MergeCellsRow()
    Dim rng As Range
    Dim Row As Long, tgc As Long
    Dim sc As Long, ec As Long
    Dim i, j As Long
    'Application.InputBoxで列を指定できるようにする
    On Error Resume Next
    Set rng = Application.InputBox( _
        Prompt:="対象行のセル範囲を選択指定するか" & vbCrLf & _
        "行の先頭セルを選択してください!", Title:="対象セル選択", Type:=8)
    On Error GoTo 0
    If rng Is Nothing Then Exit Sub
    '選択された先頭セルの行と列の番号を取得します
    Row = rng.Row
    sc = rng.Column
    'セル選択状態を判定して最終列を取得します
    If rng.Count = 1 Then
        ec = Cells(Row, Columns.Count).End(xlToLeft).Column '先頭だけ選択の場合
    Else
        ec = sc + rng.Count - 1 '範囲で選択している場合
    End If
    Set rng = Cells(Row, sc)    '先頭セルをRangeオブジェクト変数に代入
    
    For tgc = sc To ec - 1      '最終列の一つ手前までループ処理
        With Cells(Row, tgc)
            '次のセルとセルの値を比較して同じ間はセル範囲を広げます
            If .Value = .Offset(0, 1).Value Then
                Set rng = Union(rng, .Offset(0, 1))
            Else
             '値が違うセルが出現したら広げていた範囲を結合します
               Application.DisplayAlerts = False
                rng.Merge
                rng.HorizontalAlignment = xlHAlignCenter '横中央
                'rng.VerticalAlignment = xlVAlignCenter   '縦中央
                Application.DisplayAlerts = True
                Set rng = .Offset(0, 1)    '次のセルをRange変数に代入
            End If
        End With
    Next
    '範囲の一番最後が前のセルと同じだった場合の結合処理
    If rng.Count > 1 Then 'Range変数が複数だった場合結合します
        Application.DisplayAlerts = False
        rng.Merge
        rng.HorizontalAlignment = xlHAlignCenter '横中央
        'rng.VerticalAlignment = xlVAlignCenter   '縦中央
        Application.DisplayAlerts = True
    End If
End Sub

コード内容を補足解説します

・コード内にコメントを入れているので参照してください。以下は補足説明です。
・18~22行目で、対象範囲の最終列番号を確定させています。
・25行目からループ処理開始。最終は最終列番号の一つ手前までにしています。
★その理由は、列の場合と同じです。
★以下の「Offsetプロパティ」は「列」用に変更しています。
・28行目で、対象セルとその右のセル「.Offset(0, 1)」の値を比較しています。
・29行目、同一だった場合、Set rng = Union(rng, .Offset(0, 1)) でRange変数の範囲を拡張してセットし直しています。
・32~36行目は、値の違うセルが出現した場合、それまでのセル範囲でセル結合を実行しています。値の位置を「横中央」に設定しています。
・42~48行目、最後のセルが前のセルと同一だった場合、ループ内で結合処理が完結していないのでその処理をここで行っています。Range変数が複数かどうか判定して実行します。

実行GIF画像

「結合セル」の解除方法も解説しています。参考に是非ご覧ください(^^)/

スポンサーリンク

まとめ(おわりに)

・いかがでしたでしょうか?
「いつも汎用でだれでも使えて活用できるように考えてVBAを使う」というポリシーを念頭に今回の記事も書いたつもりです。
実行例のイメージが掴みづらいので「GIF画像」を配置しました
サンプルファイルを用意していますのでよろしければお使いください(^^)

まとめと感想など

くるみこ
くるみこ

自動でセルを結合する方法はいかがでしたか? 

仕組みをよく考えていけばやり方が見えてくる良い例だったと思います(^^)

はい!  何をしたいのかを考えるのが大事なんですね。
UnionメソッドとOffsetの使い方がよくわかりました(^^)

くるみこ
くるみこ

セル結合についてはこのくらいにしましょう。次回からはテーブル操作に関することを題材として検討してみたいと思います(^^)/

【今回分かったことは】
UnionメソッドとOffsetを使ったセル範囲の操作方法
・隣接するセルを比較して同一ならセル範囲を広げる方法
・隣接するセルを比較して相違していたら直前のセル範囲を結合する方法


ブログランキングに参加しています(^^) 応援よろしくお願いしますm(_ _)m

今後の記事について

今回の記事はいかがだったでしょうか。皆さまのお役に立てたなら幸いです(^^;
「汎用でだれでも使えて活用できるように考えてVBAを使う」というポリシーで、記事を継続して書いていきたいと思っています。どうぞよろしくお願いしますm(_ _)m

【検討中の今後の記事内容は・・・・・】
・実務に役立つものを提供できるよう常に検討しています(^^ゞ
・その他雑記的に「プチネタなど」もいろいろ考えていきたいと思います・・・・・
・今後の記事にもご期待ください(^^)/

記事のサンプルファイルをダウンロードできます

今回の記事のサンプルをダウンロードできるようにしています
過去の記事で使用したサンプルファイルがダウンロードできるページを設置しています
こちら(このリンク先)からご利用ください

スポンサーリンク

スポンサーリンク