Speed up Macro performance-CodePudding

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

CodePudding user response：

For a quick fix add

Application.Calculation = xlManual

after your code

Application.DisplayAlerts = False
Application.ScreenUpdating = False

and

Application.Calculation = xlAutomatic

after your code

Application.DisplayAlerts = True
Application.ScreenUpdating = True

and to improve the macro not processing blank ranges,

dim ws as worksheet
dim lastrowA, lastrowB, lastrow C as long


'Instead of setting last row to 2000, can use the actual last row by eg:

'find last row of data in column A'
lastrowA = ws.Cells(Rows.Count, 1).End(xlUp).Row

'find last row of data in column B'
lastrowB = ws.Cells(Rows.Count, 2).End(xlUp).Row

'find last row of data in column C'
lastrowC = ws.Cells(Rows.Count, 3).End(xlUp).Row

and insert these into the macro instead of 2000 eg:

Set myrange = Range("A2:A" & lastrowA & ,

CodePudding user response：

The slowdown in your code is primarily due to the presence of the GoTo CheckAgain transition, due to which the cycle of processing the same cells is repeated many times. In addition, multiple calls to the cells of the sheet are used, which is very time consuming. In the code below, unnecessary cycles are excluded, reading data from the sheet, merging and formatting cells are performed immediately for the entire processed subrange.

I ran the code on 2 sheets with 10000 rows each, it took 2.6 sec.

Option Explicit

Sub test1()
    'Here we indicate only the starting cells in each column, because
    'the size of the non-empty area in these columns is calculated
    'automatically in the MergeCells() procedure
    MergeCells Sheets("1").Range("A2,B2,L2,M2,N2,O2")
    MergeCells Sheets("2").Range("A2,B2,L2,M2,N2,O2")
End Sub

Sub MergeCells(myrange As Range)
    Dim v As Variant, col As Range, Cell As Range, toMerge(0 To 1) As Range, k As Long, index As Byte, area As Variant, arr As Variant, skip As Boolean
    
    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    
        For Each col In myrange
            ' next line reads all the data from sheet's column at once
            arr = col.Resize(myrange.Parent.Cells(Rows.Count, col.Column).End(xlUp).Row - col.Row   1)
            
            For k = LBound(arr, 1) To UBound(arr, 1) - 1 'loop through all rows of an array
                If Not skip And arr(k, 1) = arr(k   1, 1) And Not IsEmpty(arr(k, 1)) Then
                    'to prevent "gluing" adjacent sub-ranges within the same range,
                    'two ranges are used in the toMerge array, all odd sub-ranges are collected
                    'in the element with index 0, all even ranges are collected in the element
                    'with index 1, and Index switches from 0 to 1 and vice versa after each array subrange
                    If toMerge(index) Is Nothing Then
                        Set toMerge(index) = col.Offset(k - col.Row   1).Resize(2)
                    Else
                        Set toMerge(index) = Union(col.Offset(k - col.Row   1).Resize(2), toMerge(index))
                    End If
                    index = 1 - index
                    skip = True ' if merged, skip next cell
                Else
                    skip = False
                End If
            Next
            ' if the ranges for merge are non-empty, we merge and format simultaneously for all subranges
            For Each area In toMerge
                If Not area Is Nothing Then
                    area.Merge
                    area.VerticalAlignment = XlVAlign.xlVAlignCenter
                End If
            Next
            Set toMerge(0) = Nothing
            Set toMerge(1) = Nothing
        Next
        
        .DisplayAlerts = True
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
    End With
End Sub