Merge cell excel VBA time performance

Question

I have a performance problem in my VBA-Excel code. I have 42 rows and 55 columns (it can be increased). My purpose is to merge the cells (in each 2 rows) that have same value using some steps (I want to make a gantt chart).

Before merge

After merge

The first step is merged on column based (for each 2 rows):

compare cell (row, col) and (row+1, col)
If it has same value, compare cell (row, col) and (row, col+1)
if it has same value, compare cell (row, col+1) and (row+1, col+1), check the next column, and go to step 1
if step 2 or 3 is false, then merge the cells from the first cell (row, col) until the last cell that have same value (cell(row + 1, col + n - 1)
if step 1 is false, then go to the next column

after that, I have to merge on row based (still for each 2 rows).

if the cell(row, col) and cell (row, col + 1) are not merged, if cell (row, col) and cell (row, col + 1) have the same value, go to next column.
if step 1 is false, then merge the cells from cell(row, col) until cell(row, col + n - 1)

I have created the code below, but I am facing a performance issue.

The time to finish this code is at least 4 minutes.

I tried to remove the merge line for checking, and the time is only 1 second.

I concluded that there is something not correct on the merge process, but I couldn't figure it out.

If you have any suggestion regarding my code, please share it.

Thank you very much...

Sub MergeCell()
Dim StartTime As Double, RunTime As Double
StartTime = Timer

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.DisplayStatusBar = False
Application.Calculation = xlCalculationManual

Dim i As Long, j As Long, jmax1 As Long, maxRows As Long, maxCols As Long
Dim merge As Long, iMerge As Long, jMerge As Long, Jump As Long
Dim chckst As String

maxRows = 42
maxCols = 55

Dim Rng As Range, Rng3 As Range
Set Rng = Sheets("Sheet1").Range("E5").Resize(maxRows, maxCols)
Dim chk As Long

i = 1
Do While i < maxRows
    j = 1
    Do While j < maxCols
        iMerge = 0
        jMerge = 0
        merge = 0
        Jump = 0
        If Rng.Cells(i, j).Value2 = Rng.Cells(i + 1, j).Value2 Then
            jmax1 = j
            iMerge = i + 1
            jMerge = jmax1
            merge = 1
            For chk = jmax1 + 1 To maxCols - 1
                If Rng.Cells(i, j).Value2 = Rng.Cells(i, chk).Value2 Then
                    If Rng.Cells(i, chk).Value2 = Rng.Cells(i + 1, chk).Value2 Then
                        jmax1 = jmax1 + 1
                    Else
                        Jump = 1
                        Exit For
                    End If
                Else
                    Exit For
                End If
            Next
        Else
            j = j + 1
        End If
        If merge > 0 Then
            'when I removed this merge line, the speed is good, like I said before
            Range(Rng.Cells(i, j), Rng.Cells(iMerge, jmax1)).merge
            j = jmax1 + 1
            If Jump = 1 Then
                j = j + 1
            End If
        End If
    Loop
    i = i + 2
Loop

RunTime = Round(Timer - StartTime, 2)
MsgBox "Run Time = " & RunTime & " seconds", vbInformation

Dim colId1 As Long, colId2 As Long
Dim colct As Long
i = 1
Do While i <= maxRows
    j = 1
    Do While j < maxCols
        merge = 0
        jmax1 = j
        If Rng.Cells(i, jmax1).MergeCells = True Then
            colct = Rng.Cells(i, jmax1).MergeArea.Columns.Count - 1
            jmax1 = jmax1 + colct
            j = jmax1 + 1
        Else
            For chk = jmax1 + 1 To maxCols
                If Rng.Cells(i, j) = Rng.Cells(i, chk) And Rng.Cells(i, chk).MergeCells = False Then
                    merge = 1
                    colId1 = j
                    colId2 = jmax1 + 1
                    If chk <> maxCols Then
                        jmax1 = jmax1 + 1
                    Else
                        j = jmax1 + 1
                        Exit For
                    End If
                Else
                    j = jmax1 + 1
                    Exit For
                End If
            Next
        End If
        If merge > 0 Then
           'when I removed this merge line, the speed is good, like I said before               
           Range(Rng.Cells(i, colId1), Rng.Cells(i, colId2)).merge
        End If
    Loop
    i = i + 1
Loop

Rng.HorizontalAlignment = xlCenter
Rng.VerticalAlignment = xlCenter

On Error GoTo HERE
HERE:

Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.DisplayStatusBar = True
Application.Calculation = xlCalculationAutomatic

RunTime = Round(Timer - StartTime, 2)
MsgBox "Done!" & vbNewLine & "Run Time = " & RunTime & " seconds", vbInformation

End Sub

I advise you to stop using Goto in your code. It is impossible to follow. Can you post a screenshot of your sheet before and after running this code? — jkpieterse
@jkpieterse I have put the screen shot of my sheet before and after. I have modified Goto into For loop. — Umar S

Umar S Umar S · Accepted Answer · 2017-02-24T22:48:16

The problem is in the conditional formatting.

I only need to remove the conditional formatting before merge, merge it, then put the conditional formatting again.

With this code, everything is fine and fast now. It's only need 2 seconds.

thank you for everyone who contributes to help..

regards,

Merge cell excel VBA time performance

2 Answers