Merged cells are a big pain with vba.
I can't arrange for the middle cell of 3 merged cells to contain the value (as in your picture), Excel only allows the top left cell of a merged range to contain the value.
In the macro below, I've arranged for the 4 rightmost columns to be merged in the same way as the first column, and each merged area will take on the value of the top cell in that area, losing any values that are different in the other cells (if they're all the same, consider removing duplicate rows instead; it's built in and faster).
There should be no merged cells before you start.
There are entire lines of code commented out which I used as debug lines which can be deleted.
According to your picture the data body seems to start in row 3, hence the line rw = 3 'start row in the code.
Sub blah() lr = Cells(Rows.Count, "M").End(xlUp).Row rw = 3 'start row Set myRng = Range(Cells(rw, "M"), Cells(lr, "M")) ' myRng.Select Set TopCell = myRng.Cells(1) Set BottomCell = myRng.Cells(1) myVal = TopCell.Value For Each cll In myRng.Cells If cll.Value = myVal Then Set BottomCell = cll Else Range(TopCell, BottomCell).Select If TopCell.Row <> BottomCell.Row Then ' merge: For ofst = 4 To 0 Step -1 ' Range(TopCell, BottomCell).Offset(, ofst).Select Merge Range(TopCell, BottomCell).Offset(, ofst) Next ofst End If ' cll.Select Set TopCell = cll myVal = TopCell.Value Set BottomCell = cll End If Next cll Range(TopCell, BottomCell).Select If TopCell.Row <> BottomCell.Row Then ' merge For ofst = 4 To 0 Step -1 ' Range(TopCell, BottomCell).Offset(, ofst).Select Merge Range(TopCell, BottomCell).Offset(, ofst) Next ofst End If End Sub Sub Merge(Rng) ' Rng.Select With Rng .VerticalAlignment = xlCenter Application.DisplayAlerts = False .MergeCells = True Application.DisplayAlerts = True End With End Sub






Reply With Quote