Merge cells in a range based on cell value but the last cells aren't being merged

Question

I have a range with rows with data from columns A to K. There is already blank row between every new change in cell value in column C. I want to merge the data in column c based off whether the values are the same PLUS one blank row below. I absolutely need the merge to include one blank row for each unique cell value in column B because i will be grouping values later.

The current code I have merges everything except for the last unique value...Could anyone help me adjust my code so that i can also include my last unique value?

Sub MergeSameValue()
Application.DisplayAlerts = False
Dim LastRow As Integer
Dim StartRow As Integer
StartRow = 12
LastRow = Range("B" & Rows.Count).End(xlUp).Row

Dim StartMerge As Integer
StartMerge = StartRow

For i = StartRow + 1 To LastRow + 1
   If Cells(i, 2) <> "" Then
        If Cells(i, 2) <> Cells(i - 1, 2) Then
            Range(Cells(i - 1, 2), Cells(StartMerge, 2)).Merge
            StartMerge = i
        End If
    End If
Next i

End Sub

Wiz Wiz · Accepted Answer · 2021-08-11T18:08:40

Your code states that the cell you are currently checking in the loop can't be blank i.e. If Cells(i, 2) <> "" Then. If cells are not blank then you check if you should merge.

Since the last part will never fulfill that criteria (when i = 28, the code line Cells(i, 2) <> "" will never be true. So in my example below, row 28 will always be the last cell and it will never have a value). Therefore your code will never move to next part: If Cells(i, 2) <> Cells(i - 1, 2) Then... and try to merge the last part.

You can try this by adding a value to cell B28 and the category "diary" will be merged.

By adding an exception to the last row, this will solve your problem.

Note: I would recommend to hide alerts only when you merge. Otherwise is easy to be surprised if different part of the code doesn't work as expected since it will be hided due to alerts are hidden.

Full code:

Sub MergeSameValue()

Dim LastRow As Long
Dim StartRow As Long
StartRow = 12
LastRow = Range("B" & Rows.Count).End(xlUp).Row

Dim StartMerge As Long
StartMerge = StartRow

For i = StartRow + 1 To LastRow + 1
   If Cells(i, 2) <> "" Then
        If Cells(i, 2) <> Cells(i - 1, 2) Then
            Application.DisplayAlerts = False
            Range(Cells(i - 1, 2), Cells(StartMerge, 2)).Merge
            Application.DisplayAlerts = True
            StartMerge = i
        End If
    End If
    
    If i = LastRow + 1 Then ' for the last row, make an exception and check and run merge
        Application.DisplayAlerts = False
        Range(Cells(i, 2), Cells(StartMerge, 2)).Merge 'To add a blank space for the last row in the merge, remove the -1.
        Application.DisplayAlerts = True
    End If
    
Next i

End Sub

Result:

Merge cells in a range based on cell value but the last cells aren't being merged

1 Answers