【VBA】同じ値が連続するセルを結合する

 前エントリの「デシジョンテーブルを自動生成する」に於いて、
「YNYN・・・」と延々と続くのは美しくない。

ある程度、整形されていたほうが見やすいし、間違いも発見しやすい。

そこで、同じ値が連続してセルに設定されている場合、
セル同士を結合するマクロを作りました。

連続するセルを結合する

デシジョンテーブルを作ると上の図のように「Y」と「N」がいっぱい並んで見づらいですよね？
そこで同じ値を結合したのが下の図です。
どうでしょうか？視認性が向上したのではないでしょうか？

セル結合マクロ

Sub MergeCells()
    Dim row As Integer
    Dim i, j As Integer

    row = ActiveCell.row()

    With ActiveSheet
        Do Until .Cells(row, ActiveCell.Column()).Value = ""
            i = ActiveCell.Column()
            j = i + 1
            
            Do Until .Cells(row, j).Value = ""
                If .Cells(row, i).Value = .Cells(row, j).Value Then
                    ' １．値が同じ場合は結合
                    Application.DisplayAlerts = False
                    .Range(.Cells(row, i), .Cells(row, j)).MergeCells = True
                    Application.DisplayAlerts = True

                    '' ２．セルを結合せずに文字だけ消す場合
                    '.Cells(row, j).Value = ""

                    '' ３．文字も消さずに白文字にする場合
                    '.Cells(row, j).Font.ColorIndex = 2      ' ColorIndex = 2 :白

                    j = j + 1
                Else
                    i = j
                    j = j + 1
                End If
            Loop

            row = row + 1
        Loop
    End With
End Sub

今回は、同じ値のセルを結合しましたが、
20行目を有効にすれば、結合せずに文字だけ削除します。
23行目を有効にすれば、文字は消さずに白文字にします。

後々メンテが入るなら「３．文字も消さずに白文字にする場合」がオススメです。

このマクロは横方向に対してセル結合をしていますが、
縦方向に対してセルを結合した場合は、.Cells(row, col)となっている部分を
全て .Cells(col, row) のように入れ替えてください。




以上