縦に並ぶ同じ内容のセルを結合するマクロ

2021.06.11

みなさん、こんにちは、
みむすたーです。

本日は、仕事上でマクロがあったら良いのに、
というExcel VBAマクロがあったので、ご紹介します。

それではいきましょう。

もくじ

マクロ動作

ソースコード

以下の通りです。

Sub Macro1()
'マージ時の警告文を無効にする
 Application.DisplayAlerts = False
 
 Dim col As Integer
 col = Selection(1).Column
 If Selection.Row > 1 Then
    ' 結合幅を合わせるために上のセルの幅を取得する
    Selection.Offset(-1, 0).Select
    col = Selection(Selection.Count).Column
    Selection.Offset(1, 0).Select
 End If
 
 Dim str1, str2 As String
 Dim pre_row, cur_row As Integer
 str1 = Selection(1).Value
 str2 = str1
 pre_row = Selection(1).Row
 cur_row = pre_row
 
 While str1 = str2
     Selection.Offset(1, 0).Select
     str2 = Selection(1).Value
     cur_row = Selection(1).Row
     
    If cur_row - pre_row > 1000 Then
        '最後の行か判定する ( 最大結合は1000とする)
        Cells(pre_row, Selection(1).Column).Select
        MsgBox "おそらく最後の行です 。そのため、マージはしません。"
        Exit Sub
    End If
 Wend
 
 
 Range(Cells(pre_row, Selection(1).Column), Cells(cur_row - 1, col)).Select
 
 Selection.Merge
 
 Selection.Offset(1, 0).Select

End Sub

注意点

最後の行を判断するために、1000行を超えるセルを結合できなくしています。
そのため、注意が必要です。

コメント