使用 VBA 合并 2000 多个单元格？

Question

我写了以下代码来合并excel中的单元格，数据大约26000行，代码运行在8 GB RAM的核心I7 CPU上，问题是它仍然工作4天，平均每天的行数是3000行！，任何人都知道如何得到结果，因为它的报告应该从三天内交付！

Sub MergeCellss()
lastRow = Worksheets("A").Range("A65536").End(xlUp).Row

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

For i = 2 To lastRow
If Cells(i, 2).Value <> Cells(i - 1, 2).Value And Cells(i, 2).Value <> Cells(i + 1, 2).Value Then
     intUpper = i
     Debug.Print ("<> -1 and <> +1 " & intUpper)
End If

If Cells(i, 2).Value <> Cells(i - 1, 2).Value And Cells(i, 2).Value = Cells(i + 1, 2).Value Then
     intUpper = i
     Debug.Print ("<> -1 and = +1 " & intUpper & " UPPPER LIMIT")
End If


If Cells(i, 2).Value <> Cells(i + 1, 2).Value And Cells(i, 2).Value = Cells(i - 1, 2).Value Then
    Application.DisplayAlerts = False
      Debug.Print ("<> +1 and = -1:" & i & "LOWER LIMIT")
        DoEvents
         For x = 1 To 8
             Range(Cells(intUpper, x), Cells(i, x)).Merge
        Next x

        For j = 18 To 26
             Range(Cells(intUpper, j), Cells(i, j)).Merge
        Next j
        Cells(intUpper, 14).Value = "=sumif(M" & CStr(intUpper) & ":M" & CStr(i) & ","">0"")"
        Range(Cells(intUpper, 14), Cells(i, 14)).Merge
        Range(Cells(i, 1), Cells(i, 26)).Borders(xlEdgeBottom).LineStyle = xlDouble
End If

If Cells(i, 2).Value <> Cells(i + 1, 2).Value And Cells(i, 2).Value <> Cells(i - 1, 2).Value Then
     Debug.Print ("One Cells: " & i)
    Range(Cells(i, 1), Cells(i, 26)).Borders(xlEdgeBottom).LineStyle = xlDouble
      Cells(intUpper, 14).Value = Cells(intUpper, 13).Value
      DoEvents
End If

Next i
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True
End Sub

上面的代码会将包含重复数据（如用户名、出生日期……）的所有单元格合并到一个单元格中，并保持培训课程和经验不变。

我想知道如何在不到 1 小时的时间内运行此代码。

Answer 1

这是对您的代码的一些重写。两个主要区别是If ... ElseIf ... End If 的使用以及第一个和第四个条件操作的分组（条件相同）。

Sub Merge_Cells()
    Dim lastRow As Long, rw As Long
    Dim intUpper As Long, x As Long
    Dim vVALs As Variant

    appTGGL bTGGL:=False
    Debug.Print Timer

    With Worksheets("A")
        .Cells(1, 1) = Timer
        lastRow = .Cells(Rows.Count, 1).End(xlUp).Row

        For rw = 2 To lastRow
            vVALs = Array(.Cells(rw - 1, 2).Value, .Cells(rw, 2).Value, .Cells(rw + 1, 2).Value)

            If vVALs(1) <> vVALs(0) And vVALs(1) <> vVALs(2) Then
                'the first and fourth conditions were the same so they are both here
                'original first If condition
                intUpper = rw
                'Debug.Print ("<> -1 and <> +1 " & intUpper)
                'original fourth If condition
                'Debug.Print ("One Cells: " & rw)
                .Range(.Cells(rw, 1), .Cells(rw, 26)).Borders(xlEdgeBottom).LineStyle = xlDouble
                .Cells(intUpper, 14).Value = .Cells(intUpper, 13).Value
            ElseIf vVALs(1) <> vVALs(0) And vVALs(1) = vVALs(2) Then
                 intUpper = rw
                 'Debug.Print ("<> -1 and = +1 " & intUpper & " UPPPER LIMIT")
            ElseIf vVALs(1) = vVALs(0) And vVALs(1) <> vVALs(2) Then
                'Debug.Print ("<> +1 and = -1:" & rw & "LOWER LIMIT")

                For x = 1 To 26
                    If x < 9 Or x > 17 Then _
                        .Range(.Cells(intUpper, x), .Cells(rw, x)).Merge
                Next x

                .Cells(intUpper, 14).Value = "=sumif(M" & CStr(intUpper) & ":M" & CStr(rw) & ","">0"")"
                .Range(.Cells(intUpper, 14), .Cells(rw, 14)).Merge
                .Cells(rw, 1).Resize(1, 26).Borders(xlEdgeBottom).LineStyle = xlDouble
            End If

        Next rw
        .Cells(1, 2) = Timer
    End With

    Debug.Print Timer
    appTGGL
End Sub

Sub appTGGL(Optional bTGGL As Boolean = True)
    Application.Calculation = IIf(bTGGL, xlCalculationAutomatic, xlCalculationManual)
    Application.ScreenUpdating = bTGGL
    Application.EnableEvents = bTGGL
    Application.DisplayAlerts = bTGGL
End Sub

我还将三个主要条件值读入一个变量数组，以减少重复读取工作表值。