We help IT Professionals succeed at work.

VBA to merge duplicated cells in selected range

I'm trying to come up with a macro that finds Table2 and merges identical cells.

To find Table2 in the attached sheet, I could use something like this:
Dim rFind As Range
    With Sheet1
        Set rFind = .Cells.Find(what:="Table2", lookat:=xlWhole, MatchCase:=False, SearchFormat:=False)
        If Not rFind Is Nothing Then
            .Cells(rFind.Row + 1, "A").Select
        End If
    End With

Open in new window


Below is another code that can be used to merge identical cells in column D thru AD (compliments of Nawaf).  If you see my attached spreadsheet, you'll see this range has nothing to do with my scenario, but the logic may give some food for thought.
Sub MergeCells() 
    Dim lRow As Long 
    lRow = Cells(Rows.Count, "D").End(xlUp).Row 
    Application.DisplayAlerts = False 
    For i = lRow To 2 Step -1 
        If Cells(i, 4) = Cells(i - 1, 4) Then 
            Range(Cells(i, 4), Cells(i - 1, 4)).Merge 
            Range(Cells(i, 33), Cells(i - 1, 33)).Merge 
        End If 
    Next i 
    Application.DisplayAlerts = True 
End Sub 

Open in new window



If an expert could give me some direction on how to bring this together and apply it to my scenario, I'd appreciate it.  Thanks!


Merge-Example.xlsm
Comment
Watch Question

Various
CERTIFIED EXPERT
Commented:
try the attached

 
Sub TestCode()
    Dim rFind As Range
    Dim irow As Long
    Dim oldVal As String, newVal As String
    With Sheet1
        Set rFind = .Cells.Find(what:="Table2", lookat:=xlWhole, MatchCase:=False, SearchFormat:=False)
        If Not rFind Is Nothing Then
            irow = rFind.Row + 1
            Do While .Cells(irow, "A").Value <> vbNullString
                newVal = .Cells(irow, "A").Value
                If oldVal = newVal Then
                    Application.DisplayAlerts = False
                    .Range(.Cells(irow - 1, "A").Address, .Cells(irow, "A").Address).Merge
                    Application.DisplayAlerts = True
                End If
                oldVal = newVal
                irow = irow + 1
            Loop
        End If
    End With
End Sub

Open in new window


 Merge-Example-thydzik.xlsm

Author

Commented:
Nice!  This works great.  I'm going to go ahead and award you the points since I will be offline for a while, but I'd be very appreciative if you could answer this as well...

The only adjustment I need is to incorporate a center veritical and horizatal alignment for the cells in the table.  Is there an easy way to incorporate this sort of thing into your code?

        
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter

Open in new window



Thanks again! ;-)
Travis HydzikVarious
CERTIFIED EXPERT

Commented:
try the following

 
Sub TestCode()
    Dim rFind As Range
    Dim irow As Long
    Dim oldVal As String, newVal As String
    With Sheet1
        Set rFind = .Cells.Find(what:="Table2", lookat:=xlWhole, MatchCase:=False, SearchFormat:=False)
        If Not rFind Is Nothing Then
            irow = rFind.Row + 1
            Do While .Cells(irow, "A").Value <> vbNullString
                .Cells(irow, "A").HorizontalAlignment = xlCenter
                newVal = .Cells(irow, "A").Value
                If oldVal = newVal Then
                    Application.DisplayAlerts = False
                    With .Range(.Cells(irow - 1, "A").Address, .Cells(irow, "A").Address)
                        .Merge
                        .HorizontalAlignment = xlCenter
                        .VerticalAlignment = xlCenter
                    End With
                    Application.DisplayAlerts = True
                End If
                oldVal = newVal
                irow = irow + 1
            Loop
        End If
    End With
End Sub

Open in new window

Author

Commented:
Outstanding!  Thanks!!!

Explore More ContentExplore courses, solutions, and other research materials related to this topic.