Speed up macro to merge many similar cells on defined worksheets

Hi Khaled

Your code took a long time to run because (with your data saying "Test" in every cell). it checked the first cell, went through thousands of cells looking for matches then picked the second cell and went through all the same cells (except the first) etc. In all perhaps millions of cells!

In my new code below, it goes through each cell just once.

An array of sheet names is defined (and you could add one, say "September") and simple For / Next loops run through each sheet, then each column in your range, then each row in same. When a change in values is found, it merges the cells (defined by row variable MStart and MEnd) and aligns as you requested.

Before you try the revised macro, please look on sheets "1" and "2" and you will see I have:

1. added headings in row (since you defined your range from A2 etc.)
2. put different values to test the merge (e,g, "Test2" on sheet "1" cells B10:B14- shaded light blue) 
3. reduced the number of rows in "2" to 1426 (to demonstarate it handle "dynamic" sheet sizes).

I've put some key bits in bold and added comments so you understand what is happening:

Option Base 1

Sub Merge_Duplicated_Cells()



Dim myRange  As Range

Dim LstRw As Long

Dim n As Long, m As Long, ws As Long

Dim wsArr()



Application.DisplayAlerts = False

Application.ScreenUpdating = False



' define which sheet names to do this for

wsArr = Array("1", "2")



' Loop through sheet names

For ws = 1 To UBound(wsArr)

    With Worksheets(wsArr(ws))

            ' get last row of column A

            LstRw = .Range("A" & .Rows.Count).End(xlUp).Row

            'define groups of columns (to merge values)

            Set myRange = Union(.Range("A2:B" & LstRw), .Range("L2:O" & LstRw))

    End With



    ' loop though each area in the Union

    For Ar = 1 To myRange.Areas.Count



        'Loop along columns per area

        For n = 1 To myRange.Areas(Ar).Columns.Count

            MStart = 1

            MEnd = 1

            ' Loop down rows

            For m = 1 To LstRw - 1

                    With myRange.Areas(Ar).Cells(m, n)

                    If .Value = .Offset(1, 0).Value And Not IsEmpty(.Offset(1, 0)) Then

                        'same so extend end of merge

                        MEnd = m + 1



                        Else

                        'Not same so define end of merge

                        MEnd = m

                        ' merge matching cells

                        With myRange.Areas(Ar).Range(Cells(MStart, n).Address, Cells(MEnd, n).Address)

                            .Merge

                            .VerticalAlignment = xlCenter

                        End With



                        ' make new start cell

                        MStart = m + 1

                    End If

                End With

            Next m

        Next n

    Next Ar

Next ws



'    ActiveWorkbook.Save



Application.DisplayAlerts = True

Application.ScreenUpdating = True



MsgBox "Report is ready"



End Sub

Note that I have commented out the line:

ActiveWorkbook.Save

for test purposes and moved the MsgBox line until after screenupdating is restored.

Hope this fixes your speed problem.