Merge cells with same number within specific column range.

Hi Wizards,

Please can you help I am using this formula but I need the cells that have the same value between E17 and E758 merged not the whole column.

Sub mergethem()
Dim x As Long
Application.DisplayAlerts = False
For x = Range("E" & Rows.Count).End(xlUp).Row To 1 Step -1
If Range("E" & x) = Range("E" & x - 1) Then Range("E" & x - 1).Resize(2).Merge
Next x
Application.DisplayAlerts = True
End Sub

Thank so much..

Hello akima,

Welcome to the Forum!

Can you provide an example workbook with some raw data and an example of the desired result?

How To Post Your Workbook

1. At the bottom right of the Reply window, Click the button Go Advanced
2. At the top of the Your Message Window, in the first row of icons, Click the Paperclip icon.
3. Click the Add Files button at the top right in the dialog box. This displays the File Manager dialog.
4. Click the Select Files button at the bottom middle of the dialog.
5. In the new window Find the file you want to upload, select it, and Click Open.
6. You will now be back in the File Manager dialog. Click the bottom Middle button Upload File.
7. Wait until the file has completely uploaded before you exit the File Manager dialog.

Hi Akima,


You may try this,
If the code helped you, please add reputation to me by clicking "*"

Sub test()
Dim rngCell As Range

 For i = 17 To 758
    For Each rngCell In Range("E17:E758")
        
        Application.DisplayAlerts = False
          If rngCell.Value <> "" Then
            If rngCell.Value = rngCell.Offset(1).Value Then
                With Range(rngCell, rngCell.Offset(1))
                     .MergeCells = True
                     .HorizontalAlignment = xlCenter
                     .VerticalAlignment = xlCenter
                 End With
            End If
          End If
        Application.DisplayAlerts = True
    Next rngCell
  Next i
End Sub

Hi Akima,

Thanks for reputation,


Here is the better code and run very fast. Please mark as solved

Sub test()
Dim j As Long, k As Long

j = 1
    For k = 17 To 758

       If Cells(k, "E") = Cells(k + 1, "E") Then
           j = j + 1

       ElseIf j >= 2 Then
           Application.DisplayAlerts = False
               With Range(Cells(k, "E"), Cells(k - j + 1, "E"))
                   .MergeCells = True
                   .HorizontalAlignment = xlCenter
                   .VerticalAlignment = xlCenter
               End With
            Application.DisplayAlerts = True
           j = 1
       End If
    Next k
End Sub