Question

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

{{1}}

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

我想知道如何在不到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

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

使用VBA合并超过2000个单元？

1 个答案: