合并单元格excel VBA时间性能

Question

我的 VBA-Excel 代码存在性能问题。 我有 42 行和 55 列（可以增加）。 我的目的是使用一些步骤（我想制作甘特图）合并具有相同值的单元格（每 2 行）。

Before merge

After merge

第一步是基于列合并（每2行）：

1. 比较单元格（行，列）和（行+1，列）
2. 如果值相同，比较单元格(row, col)和(row, col+1)
3. 如果值相同，比较单元格(row, col+1)和(row+1, col+1)，检查下一列，然后转到步骤1
4. 如果第 2 步或第 3 步为 false，则合并从第一个单元格 (row, col) 到最后一个具有相同值的单元格 (cell(row + 1, col + n - 1) 的单元格
5. 如果第 1 步为假，则转到下一列

之后，我必须基于行合并（仍然是每 2 行）。

1. 如果单元格(row, col) 和单元格(row, col + 1) 没有合并，如果单元格(row, col) 和单元格(row, col + 1) 的值相同，则转到下一列。
2. 如果步骤 1 为假，则合并从 cell(row, col) 到 cell(row, col + n - 1) 的单元格

我已经创建了下面的代码，但我遇到了性能问题。

完成此代码的时间至少为 4 分钟。

我尝试删除合并线进行检查，时间只有1秒。

我得出的结论是合并过程中有一些不正确的地方，但我无法弄清楚。

如果您对我的代码有任何建议，请分享。

非常感谢...

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

Answer 1

问题在于条件格式。

我只需要在合并前把条件格式去掉，合并，再把条件格式再放。

有了这段代码，现在一切都很好而且很快。只需 2 秒。

感谢所有提供帮助的人..

问候，

Answer 2

Suggestion 1

像这样声明变量： Dim i as long, j as long, jmax1 as long, maxRows as long, maxCols as long 等。如果您不指定类型，它们将被声明为变体。在您的行中，只有最后一个 - Jump 被声明为 long。 如果你重新声明它们，它可能会运行得更快。

Suggestion 2

不要在 VBA 中使用整数。 stackoverflow.com/questions/26409117/

Suggestion 3

不要使用GoTohttps://en.wikipedia.org/wiki/Spaghetti_code

Suggestion 4

一般来说，VBA/Excel 中的合并很慢。但是，要查看您在做什么，请在合并之前编写以下代码： debug.Print Range(Rng.Cells(i, j), Rng.Cells(iMerge, jmax1)).Address 可能是您合并的次数超出预期或其他原因。