VBA code to merge cells with consecutive duplicate entries in Excel
Tonight, I successfully tested VBA code posted here by Extend Office, and also copied below, which you can use to merge consecutive cells with duplicate entries in a column in Excel. So, if you have multiple entries of X in consecutive cells in a column, the macro will merge those cells together but it will not merge the first range of X with a subsequent range later on in the column.
In this example, we first merge the cells in column A with the same entry. After putting the code in new module, select the range, and then go to View . . . Module and run 'MergeSameCell'.
![](https://static.wixstatic.com/media/af7fa4_6ec2f4ca10914025bb6966325c8acd97~mv2.png/v1/fill/w_980,h_689,al_c,q_90,usm_0.66_1.00_0.01,enc_avif,quality_auto/af7fa4_6ec2f4ca10914025bb6966325c8acd97~mv2.png)
![](https://static.wixstatic.com/media/af7fa4_5d94e09a6bbe46f390610081f878141b~mv2.png/v1/fill/w_859,h_719,al_c,q_90,enc_avif,quality_auto/af7fa4_5d94e09a6bbe46f390610081f878141b~mv2.png)
Consecutive duplicate entries are merged in column A, but in column B where the entries of 'New York' are not consecutive they are not merged.
![](https://static.wixstatic.com/media/af7fa4_84c6edfc48754bcdbb9c5742a4f128fb~mv2.png/v1/fill/w_593,h_480,al_c,q_85,enc_avif,quality_auto/af7fa4_84c6edfc48754bcdbb9c5742a4f128fb~mv2.png)
In order for the macro to work correctly you need to select a limited range in a column. You can't select a whole column or $A:$A.
Sub MergeSameCell()
'Updateby20131127
Dim Rng As Range, xCell As Range
Dim xRows As Integer
xTitleId = "KutoolsforExcel"
Set WorkRng = Application.Selection
Set WorkRng = Application.InputBox("Range", xTitleId, WorkRng.Address, Type:=8)
Application.ScreenUpdating = False
Application.DisplayAlerts = False
xRows = WorkRng.Rows.Count
For Each Rng In WorkRng.Columns
For i = 1 To xRows - 1
For j = i + 1 To xRows
If Rng.Cells(i, 1).Value <> Rng.Cells(j, 1).Value Then
Exit For
End If
Next
WorkRng.Parent.Range(Rng.Cells(i, 1), Rng.Cells(j - 1, 1)).Merge
i = j - 1
Next
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub