Excel VBA Course
Excel VBA Course - From Beginner to Expert

200+ Video Lessons
50+ Hours of Video
200+ Excel Guides

Become a master of VBA and Macros in Excel and learn how to automate all of your tasks in Excel with this online course. (No VBA experience required.)

View Course

Speed up macro to merge many similar cells on defined worksheets

0

Dears I need to speed up this macro performance & avoid to specified range as (A2:A2000) for example cause my data is dynamic.

  • my macro rule its check every cell with the same value in some columns to merge it
Sub Merge_Duplicated_Cells()
'
Application.DisplayAlerts = False
Application.ScreenUpdating = False

Dim ws As Worksheet
Dim Cell As Range
    
    
' Merge Duplicated Cells

    Application.DisplayAlerts = False
    
    Sheets("1").Select
    Set myrange = Range("A2:A2000, B2:B2000, L2:L2000, M2:M2000, N2:N2000, O2:O2000")
    
CheckAgain:
    For Each Cell In myrange
        If Cell.Value = Cell.Offset(1, 0).Value And Not IsEmpty(Cell) Then
            Range(Cell, Cell.Offset(1, 0)).Merge
            Cell.VerticalAlignment = xlCenter
            GoTo CheckAgain
        End If
    Next

    Sheets("2").Select
    Set myrange = Range("A2:A2000, B2:B2000, L2:L2000, M2:M2000, N2:N2000, O2:O2000")

    For Each Cell In myrange
        If Cell.Value = Cell.Offset(1, 0).Value And Not IsEmpty(Cell) Then
            Range(Cell, Cell.Offset(1, 0)).Merge
            Cell.VerticalAlignment = xlCenter
            GoTo CheckAgain
        End If
    Next

    
    ActiveWorkbook.Save

    MsgBox "Report is ready"
    
Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

[/CODE]

Answer
Discuss

Discussion

Hi Khaled

When you say "avoid to specified range as (A2:A2000) for example cause my data is dynamic", do you mean that the number of rows can vary?
John_Ru (rep: 3992) Sep 20, '22 at 5:22 am
Hi John Yes its dynamic data
Khaled1980 (rep: 4) Sep 20, '22 at 1:32 pm
Please see my Answer. Kindly mark it as Selected if it works (it took some effort on my part!)
John_Ru (rep: 3992) Sep 20, '22 at 2:49 pm
Add to Discussion

Answers

0
Selected Answer

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.

Discuss

Discussion

Hi John Its excellent effort 👍👍👍
Khaled1980 (rep: 4) Sep 20, '22 at 6:41 pm
Glad to hear that worked for you Thanks for selecting my answer, Khaled.

Please change your question title to "Speed up macro to merge many similar cells on defined worksheets" - that will be better for other users (with similar problems) searching answers
John_Ru (rep: 3992) Sep 21, '22 at 12:16 am
question title edited
Khaled1980 (rep: 4) Sep 22, '22 at 12:19 pm
Thanks Khaled
John_Ru (rep: 3992) Sep 22, '22 at 1:37 pm
Add to Discussion


Answer the Question

You must create an account to use the forum. Create an Account or Login