Dim gyou, retu As Long 'カーソルがあるせるの行= gyou、 列= retu
Dim rng As Range '結合時に使う範囲を入れる変数 = rng
Dim onaji As Integer '同じセルの個数を入れる変数 = onaji
Application.DisplayAlerts = False '結合時のダイアログ省略
gyou = ActiveCell.Row
retu = ActiveCell.Column 'スタートセルは、現在カーソルがあるセル
Do Until Cells(gyou, retu).Value = "" '空白セルがあるところまで上から順に調べる
Set rng = Cells(gyou, retu) '調べるセルを rng に代入する
With Cells(gyou, retu)
onaji = 1
Do While .Value = .Offset(onaji, 0).Value 'セル値が上下で同じか判定
onaji = onaji + 1 '同じ値のセルの個数カウント
Loop
If onaji >= 2 Then '同じ値のセルが2つ以上で結合
Range(Cells(gyou, retu), Cells(gyou + onaji - 1, retu)).Merge
'offsetの基準セルは+0個目、一つ下は+1個目 そのためonajiから1を引く
End If 'セルを結合
End With
gyou = gyou + onaji '結合すると空白セルになるので、
'同じセルだった分をgyouに加算して次へ
Loop
Application.DisplayAlerts = False '結合時のダイアログ復活