Merge based on Merged area of adjacent columns

[CodeNewb]

I have been at this for a while and it's driving me batty. It's probably much simpler than I'm making it.

To get this out of the way: I HAVE to do this. I HAVE to merge these cells. I don't like it, I don't want to, I know merging cells is always a hassle and should be avoided, but I do not have a choice.

I got a great bit of code that works fine to merge cells in multiple columns when the values in each COLUMN are the same:

Application.DisplayAlerts = False

Mergecells:
    For Each cell In Range("A3:C50")
        If cell.Value = cell.Offset(1, 0).Value And Not IsEmpty(cell) Then 
                Range(cell, cell.Offset(1, 0)).Merge
                cell.VerticalAlignment = xlCenter
                cell.HorizontalAlignment = xlCenter
                GoTo Mergecells
        End If
    Next

    Application.DisplayAlerts = True

This accomplishes the following:

Starting data (note that I have all data sorted in all the applicable columns before starting [each column sorted respectively, e.g. column A sorted, THEN column B, THEN column C, etc.]):

Merged Data (after code):

However, I only want to merge same values in each column if they fall within the rows of the merged area of the column to the left (and the first column is A). Here is what I'm trying to do:

Desired Result:

Note that there are values in columns B (and C) that might be the same, but I don't want to merge every value in each column regardless, I only want to merge values in column B where they are the same BUT ALSO fall within the merged area of one value in column A, and in C where they fall within the merged value of B, etc.

I would love to be able to do all this by beginning with the overall range (e.g. "for range A3:C5000, do this"), but it SEEMS like the only way to accomplish this is to do A first, THEN do B, but CHECK the merged area/cell count of A, THEN do C, but CHECK the merged area/cell count of column B, etc. But every experiment I try is confounded by this Excel merged cell nonsense, like when I check the cell address or merged area or merged cell count to the left, it doesn't quite work out because of how Excel handles the address or cell count of where I am in the loop and what is to the left. Plus all of those checks fail if it's the first column, because there are no cells to the left of A, etc.

Does anyone have opinion/help of a relatively efficient way of reliably doing this?

Thanks for taking the time

 

[DanteAmor]

I don't like it, I don't want to, I know merging cells is always a hassle and should be avoided, but

Follow your heart...

Put all of the following code in a module and run the Merged_area macro:

Sub Merged_area()
  Dim a As Variant, lr As Long
  
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  lr = Range("A" & Rows.Count).End(3).Row
  a = Range("A1:C" & lr + 1).Value2
  
  Call Merging_Cells(a, "C", a(3, 1) & "|" & a(3, 2) & "|" & a(3, 3))
  Call Merging_Cells(a, "B", a(3, 1) & "|" & a(3, 2))
  Call Merging_Cells(a, "A", a(3, 1) & "")
  Range("A3:C" & lr).Borders.LineStyle = xlContinuous
  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
End Sub

Sub Merging_Cells(a As Variant, col As String, ant As String)
  Dim i&, ini&, fin&, ky As String
  
  ini = 3
  For i = 3 To UBound(a, 1)
    Select Case col
      Case "A": ky = a(i, 1)
      Case "B": ky = a(i, 1) & "|" & a(i, 2)
      Case "C": ky = a(i, 1) & "|" & a(i, 2) & "|" & a(i, 3)
    End Select
    If ant <> ky Then
      fin = i - 1
      With Range(col & ini & ":" & col & fin)
        .Merge
        .VerticalAlignment = xlCenter
        .HorizontalAlignment = xlCenter
      End With
      ini = i
    End If
    ant = ky
  Next
End Sub

----- --
Let me know the result and I'll get back to you as soon as I can.
Sincerely
Dante Amor
----- --

 

[CodeNewb]

Follow your heart...

Put all of the following code in a module and run the Merged_area macro:

Sub Merged_area()
  Dim a As Variant, lr As Long
 
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  lr = Range("A" & Rows.Count).End(3).Row
  a = Range("A1:C" & lr + 1).Value2
 
  Call Merging_Cells(a, "C", a(3, 1) & "|" & a(3, 2) & "|" & a(3, 3))
  Call Merging_Cells(a, "B", a(3, 1) & "|" & a(3, 2))
  Call Merging_Cells(a, "A", a(3, 1) & "")
  Range("A3:C" & lr).Borders.LineStyle = xlContinuous
  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
End Sub

Sub Merging_Cells(a As Variant, col As String, ant As String)
  Dim i&, ini&, fin&, ky As String
 
  ini = 3
  For i = 3 To UBound(a, 1)
    Select Case col
      Case "A": ky = a(i, 1)
      Case "B": ky = a(i, 1) & "|" & a(i, 2)
      Case "C": ky = a(i, 1) & "|" & a(i, 2) & "|" & a(i, 3)
    End Select
    If ant <> ky Then
      fin = i - 1
      With Range(col & ini & ":" & col & fin)
        .Merge
        .VerticalAlignment = xlCenter
        .HorizontalAlignment = xlCenter
      End With
      ini = i
    End If
    ant = ky
  Next
End Sub

----- --
Let me know the result and I'll get back to you as soon as I can.
Sincerely
Dante Amor
----- --

This looks to have done it almost to the T Dante. Thank you SO much. I'm going to spend some time in step and watch mode to see precisely what you have going on here so I can understand it. This is my first time seeing value2, if that tells you anything about my experience level. I see you've made an array of the entire range and stepping through I see you're checking each entire row's pipe-delimited string value and merging from right to left, completely opposite from how I was trying to do it, and totally bypassing needing to check merged areas. Absolute dynamite, thanks again, greatly appreciated.