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

我已经写了下面的代码，在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 

上面的代码会将包含用户名，出生date等重复数据的所有单元格合并到一个单元格中，并将训练课程和体验保留原样。

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

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