Merge Duplicate Cells in Column Relative to Data in Next Column

[FrenchCelt]

Hello,

I'm trying to add some VBA code to a formatting macro that will take duplicate data down Column A (the data starts in A4) and merge them to fit the size of the merged cells in Column B. So something like this:

To something like this:

In looking around on my own, I have only seen code that can combine all the duplicates into one grand merged cell, and that's not what I want. Can anyone help?

 

[Juhimittal]

Sub Merge_Same_Cells()
Application.DisplayAlerts = False
Dim rng As Range
MergeCells:
For Each rng In Selection
If rng.Value = rng.Offset(1, 0).Value Or rng.Value <>"" Then
Range(rng, rng.Offset(1, 0)).Merge
Range(rng, rng.Offset(1, 0)).HorizontalAlignment = xlCenter
Range(rng, rng.Offset(1, 0)).VerticalAlignment = xlCenter
GoTo MergeCells
End If
Next

 

[Juhimittal]

Sub Merge_Same_Cells()
Application.DisplayAlerts = False
Dim rng As Range
MergeCells:
For Each rng In Selection
If rng.Value = rng.Offset(1, 0).Value And rng.Value <>"" Then
Range(rng, rng.Offset(1, 0)).Merge
Range(rng, rng.Offset(1, 0)).HorizontalAlignment = xlCenter
Range(rng, rng.Offset(1, 0)).VerticalAlignment = xlCenter
GoTo MergeCells
End If
Next

 

[FrenchCelt]

Thanks for the reply. Since it had been so long since my original post, I worked out a solution via other means. I did give your code a try since it looked a little shorter, and I prefer code elegance, but it had no effect. Thanks anyway.

Incidentally, here is the code that worked for me. I had to take some extra steps in the code to put the data in a way that would work by eliminating all the duplicate shift info per person (I used XLOOKUP to replace the shift data generated by the report by looking it up from another database and then did find and replace to remove the #N/A results generated in all the cells where there wasn't a corresponding user ID in Column B).

    Dim k, r   As Long
    Dim lr As Long: lr = Cells.Find("*", Cells(1, 1), xlFormulas, xlWhole, xlByRows, xlPrevious).Row
        For k = lr To 1 Step -1
        If Range("A" & k).Value <> "" And Range("A" & k).Offset(0, 1).MergeCells = True Then
        r = Range("A" & k).Offset(0, 1).MergeArea.Count
        Range("A" & k).Resize(r, 1).Merge
        Range("A" & k).VerticalAlignment = xlTop
        Range("A" & k).HorizontalAlignment = xlCenter
        End If
    Next k