Need Help With Macro to Merge Cells

[bjw122]

I need a macro that will merge cells that have equal adjacent values in a column. For example if I have a worksheet set up like this:

Column A

• 
  Teach
  Teach
  Old
  Dog
  Dog
  New
  New
  Tricks
  Tricks
  Teach
  Teach
  Teach

The output I want is this:

Column A

• 
  Teach
  [Cell Merged With 1 Cell Above]
  Old
  Dog
  [Cell Merged With 1 Cell Above]
  New
  [Cell Merged With 1 Cell Above]
  Tricks
  [Cell Merged With 1 Cell Above]
  Teach
  [Cell Merged With Cells Above]
  [Cell Merged With Cells Above]

However, the following code won't work because it will merge the first grouping of rows containing the word, "Teach" with the other grouping containing the word "Teach".

Sub MergeColA()

Dim c As Range, A As Range
Dim RwsToMrg As Long

With Application
  .ScreenUpdating = False
  .DisplayAlerts = False
End With

Set A = Range(Cells(1,1), Cells(Rows.Count,1).End(xlUp))

' Eliminate trailing whitespace in the input
For Each c in A
  c.Value = Trim(c.Value)
Next c

For Each c in A
  RwsToMrg = Application.WorksheetFunction.CountIf(A,c)
  If RwsToMrg > 1 Then
  With c.Resize(RwsToMrg,1)
    .Merge
    .VerticalAlignment = xlTop
  End With
End If
Next c

With Application
  .ScreenUpdating = True
  .DisplayAlerts = True
End With 
End Sub

This macro fails in this application because of how CountIf() works relative to what I need a function to do. I essentially need a macro that will iterate through the rows of a column, merging cells that contain an equivalent value to the cell above the current row. If there is a match, then merge, otherwise move on to the next row. I'm hoping there is a straightforward way to use a derivative of the function above that doesn't utilize CountIf().

 

[Greg Truby]

Why are you merging cells with like values? Is it structurally desirable? Or is it just to make the presentation look cleaner?

 

[Andrew Poulsom]

I avoid merged cells like the plague because they casue more problems than they solve. That said, this worked for me:

Sub MergeColA()
    Dim c As Range, A As Range
    Dim RwsToMrg As Long
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With
    Set A = Range(Cells(1, 1), Cells(Rows.Count, 1).End(xlUp))
' Eliminate trailing whitespace in the input
    For Each c In A
        c.Value = Trim(c.Value)
    Next c
    RwsToMrg = 1
    For Each c In A
        If c.Value = c.Offset(1, 0).Value Then
            RwsToMrg = RwsToMrg + 1
        ElseIf RwsToMrg > 1 Then
            With c.Offset(-RwsToMrg + 1, 0).Resize(RwsToMrg, 1)
                .Merge
                .VerticalAlignment = xlTop
            End With
            RwsToMrg = 1
        End If
    Next c
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
End Sub

 

[bjw122]

Hey Greg, yes, this is just to make the appearance more desirable. If you have a solution that is not a merge but still results in a similar appearance please let me know. . .I would appreciate it.

In the meantime I'll give Andrew's solution a go! Thanks Andrew.

 

[Greg Truby]

Hi bjw,

1. This appears to be a continuation of this thread where Dan and Erik were trying to help you. Normally you should post back on the original thread since the code you cite is based on code originally provided by Dan (HalfAce). Dan would be most familiar with his own code. In this case the code is not overly complex and Andrew is more than capable of quickly comprehending it.
2. On that other thread, I posed the same question and cross referenced other threads that discussed this issue. Andrew, above just said the same thing I said on your other thread, which is that experienced Excel users try to avoid merging cells unless it's truly needed. Otherwise they tend to create more headaches than they solve.
3. If you'll look at the other threads, for example here or here, you'll see that all you need to is apply a little conditional formatting, setting the font to white and the background pattern to solid white for cells where the value is equal to the cell above. Look at the examples in the other threads and you'll see that this cleans up the presentation while not making a mess of your data area's structure &/or contents.

Hope this helps,

 

[HalfAce]

I have to agree about trying to avoid merging cells whenever humanly possible. There are just too many options available that avoid the problems that merging tends to cause. (I just don't seem to have the ability to think ahead enough to ask why someone wants to like Greg does. )

Another option worth considering (and I'm not sure this has been mentioned yet but I think so) is ASAP utilities.
http://www.asap-utilities.com/
I know there is a lot of stuff in there, but like anything else, you use it often enough you learn how to get to it pretty quickly.
For what you're doing in this case the steps would be:
Select your range
Choose ASAP Utilities from the menu bar
Choose Range
Choose Empty duplicates in selection.

Of course, this too will have a negative effect on pivot tables with the data, but at least they're not merged.


(And Greg, if I'm ever capable of writing anything that Andrew can't quickly comprehend then I'll know I'm really getting somewhere! )

Dan

 

[Zack Barresse]

The horizontal alignment property CenterAcrossSelection can be used instead of merged cells.

 

[HalfAce]

Morning Zack,
The only problem with that in this case is the OP wants to do this in a verticle selection, all within one column...

 

[Zack Barresse]

Yeah, I wasn't trying to step on any toes, just wanted to make sure it was thrown out there, for reference. Sorry for any confusion.

 

[HalfAce]

Ahh, go ahead & step on 'em.
(Now that you can fix 'em right back up when you're done!)