これは仕事をするはずです。
Option Explicit
Private Sub MergeCells()
' Disable screen updates (such as warnings, etc.)
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim rngMerge As Range, rngCell As Range, mergeVal As Range
Dim i As Integer
Dim wks As Worksheet
Set wks = ThisWorkbook.Sheets("Sheet1") ' Change Sheet1 to your worksheet
i = wks.Range("A2").End(xlDown).Row
Set rngMerge = wks.Range("A2:A" & i) ' Find last row in column A
With wks
' Loop through Column A
For Each rngCell In rngMerge
' If Cell value is equal to the cell value below and the cell is not empty then
If rngCell.Value = rngCell.Offset(1, 0).Value And IsEmpty(rngCell) = False Then
' Define the range to be merged
' Be aware that warnings telling you that the 2 cells contain 2 differen values will be ignored
' If you have 2 different sums in column C, then it will use the first of those
Set mergeVal = wks.Range(rngCell.Offset(0, 2), rngCell.Offset(1, 2))
With mergeVal
.Merge
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
End If
Next
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
何を試しましたか?何かを試して、あなたが立ち往生したときにポストバックしてください。私たちはコード作成サービスではありませんが、困ったときや援助が必要なときに役立ちます。 – Sorceri