Excel vba merge cells based on duplicate cell data

[Rasscal]

Hi

im trying to figure out VBA modlue code on how to merge cells based on duplicate cell data in rows.
The columns will not change, but rows & number of duplicates are unknown (sometimes 2 rows, sometimes 3+ rows & sometimes none)

column M N O P Q

Outermost Container	Length	Width	Height	Weight
c1
c2
c2
c2
c3
c3

would become

Outermost Container Length Width Height Weight c1 (blank) c2 (blank) c3 (blank)

Capture.jpg

please could somebody help with this?

[Rasscal]

here is what i have so far, this is good for the "outermost container" column but i still cannot deal with the right empty columns

Sub Merge()
Dim dataRng As Range
Dim cellRng As Range


Application.DisplayAlerts = False


With ActiveSheet.Range("M:M")
Set dataRng = Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
End With


MergeCells:


For Each cellRng In dataRng
    If cellRng.Value = cellRng.Offset(1, 0).Value And cellRng.Value <> "" Then
    Range(cellRng, cellRng.Offset(1, 0)).Merge
    Range(cellRng, cellRng.Offset(1, 0)).HorizontalAlignment = xlLeft
    Range(cellRng, cellRng.Offset(1, 0)).VerticalAlignment = xlCenter
    GoTo MergeCells:
    End If
Next
    
End Sub

[snb]

Avoid merged cells in VBA.

[Rasscal]

Avoid merged cells in VBA.

thanks for the tip but i have no choice on this occasion, im trying to automate a process that cannot be changed.

[snb]

You are mistaken.

[p45cal]

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