为什么这个locking？ 循环遍历所有行，重复执行函数，删除重复行

当我每次咬掉几百行代码时，代码就会起作用，但是当我尝试运行它时，它总是挂在中间的某个地方。

代码的作用是：在列A中查找重复的条目，在两行之间的列c，d和e中添加值，然后删除原始行。

任何人都可以想一个更稳定的方式来做到这一点，或者指出为什么它可能会被locking？

Sub combineDelete () Const TEST_COLUMN As String = "A" Dim i As Long Dim iLastRow As Long With ActiveSheet iLastRow = .Cells(.Rows.Count, TEST_COLUMN).End(xlUp).Row For i = iLastRow To 2 Step -1 If Cells(i, 1) = Cells(i - 1, 1) Then s = Cells(i, 3).Value t = Cells(i - 1, 3).Value Cells(i - 1, 3) = s + t u = Cells(i, 4).Value v = Cells(i - 1, 4).Value Cells(i - 1, 4) = u + v w = Cells(i, 5).Value y = Cells(i - 1, 5).Value Cells(i - 1, 5) = w + y Cells(i, 1).EntireRow.Delete End If Next i End With End Sub 

编辑：这里是一个数据样本子集的链接。

后编辑：这些想法中的每一个都是有效的。 罗恩·罗森伯格（Ron Rosenberg）的解决scheme设法处理比任何解决scheme快几个数量级。 谢谢！

Answer 1

这是一个应该快速运行的例程。 如果需要，您可以在代码顶部附近注意，在哪里更改源代码和结果工作表。

这个工作是在VBA数组中完成的，这比在工作表上工作要快得多。

我创build一个用户定义的对象，其属性是TestColumn的内容; B栏中的最大金额; 以及列C，D和E的总和的数组

这些被放置在一个Collection对象中，Key是TestColumn。 如果存在重复，则Collection对象将返回一个457错误，我们testing该错误并将其用于合并行。

最后，我们将集合对象写回数组，然后将该数组写入工作表。

你将同时使用一个Class Module和一个Regular Module

原始数据不需要sorting，但可以在运行此macros之前或之后进行sorting。

请享用。

类模块

插入后请务必重命名此模块cCombo

 Rename this module **cCombo** Option Explicit Private pTestColumn As String Private pMaxColumn As Double Private pSumColumns(3 To 5) As Variant Public Property Get TestColumn() As String TestColumn = pTestColumn End Property Public Property Let TestColumn(Value As String) pTestColumn = Value End Property Public Property Get MaxColumn() As Double MaxColumn = pMaxColumn End Property Public Property Let MaxColumn(Value As Double) pMaxColumn = IIf(pMaxColumn > Value, pMaxColumn, Value) End Property Public Property Get SumColumns() As Variant SumColumns = pSumColumns End Property Public Property Let SumColumns(Value As Variant) Dim I As Long For I = LBound(Value) To UBound(Value) pSumColumns(I) = pSumColumns(I) + Value(I) Next I End Property 

常规模块

 Option Explicit Sub combineDelete() Const TEST_COLUMN As String = "A" Dim vSrc As Variant, vRes As Variant, rRes As Range Dim wsSrc As Worksheet, wsRes As Worksheet Dim cC As cCombo, colC As Collection Dim I As Long, J As Long, V As Variant, S As String Set wsSrc = Worksheets("sheet1") Set wsRes = Worksheets("sheet2") 'could be same sheet if you want to overwrite Set rRes = wsRes.Cells(2, 1) 'Get original data With wsSrc vSrc = Range(.Cells(2, TEST_COLUMN), .Cells(.Rows.Count, TEST_COLUMN).End(xlUp)).Resize(columnsize:=5) End With ReDim V(3 To UBound(vSrc, 2)) 'for storing rows 'Collect the data, eliminating duplicates Set colC = New Collection On Error Resume Next For I = 1 To UBound(vSrc, 1) Set cC = New cCombo With cC .TestColumn = vSrc(I, 1) .MaxColumn = vSrc(I, 2) For J = 3 To UBound(vSrc, 2) V(J) = vSrc(I, J) Next J .SumColumns = V colC.Add Item:=cC, Key:=.TestColumn Select Case Err.Number Case 457 Err.Clear colC(.TestColumn).MaxColumn = .MaxColumn colC(.TestColumn).SumColumns = .SumColumns Case Is <> 0 Debug.Print Err.Number, Err.Description Stop End Select End With Next I On Error GoTo 0 'Create results array ReDim vRes(1 To colC.Count, 1 To 5) For I = 1 To colC.Count With colC(I) vRes(I, 1) = .TestColumn vRes(I, 2) = .MaxColumn V = .SumColumns For J = LBound(V) To UBound(V) vRes(I, J) = V(J) Next J End With Next I 'Write the results Set rRes = rRes.Resize(UBound(vRes, 1), UBound(vRes, 2)) With rRes .EntireColumn.Clear .Value = vRes .EntireColumn.ColumnWidth = 5 End With End Sub 

Answer 2

从这开始，让我们知道事情是怎么回事：

 Option Explicit Sub combineDelete() Const TEST_COLUMN As String = "A" Dim i As Long Dim iLastRow As Long Dim s As Double, t As Double, u As Double Dim v As Double, w As Double, y As Double With Application .ScreenUpdating = False .Calculation = xlCalculationManual .EnableEvents = False End With With ActiveSheet iLastRow = .Cells(.Rows.Count, TEST_COLUMN).End(xlUp).Row For i = iLastRow To 2 Step -1 If .Cells(i, 1).Value2 = .Cells(i - 1, 1).Value2 Then s = .Cells(i, 3).Value2 t = .Cells(i - 1, 3).Value2 .Cells(i - 1, 3).Value2 = s + t u = .Cells(i, 4).Value2 v = .Cells(i - 1, 4).Value2 .Cells(i - 1, 4).Value2 = u + v w = .Cells(i, 5).Value2 y = .Cells(i - 1, 5).Value2 .Cells(i - 1, 5).Value2 = w + y .Rows(i).EntireRow.Delete End If Next i End With With Application .EnableEvents = True .Calculation = xlCalculationAutomatic .ScreenUpdating = True End With End Sub 

笔记：

1. 禁用屏幕更新，计算和事件
2. 使用.Value2而不是.Value
3. 显式编码
4. 缺less对通过添加点添加的ActiveSheet引用.
5. 将所有variables变暗以避免变体

Answer 3

处理大约10K行将从变体数组中大大受益，但也可以通过一次性删除所有行来进行重大改进。 虽然可以收集要删除的行的联合 ，但是在这种情况下， Range.RemoveDuplicates方法也适用。

目前尚不清楚您的数据是否在列A的主键上sorting。您当前的代码取决于此，但是我已经将条件检查更改为Excel应用程序对象的MATCH函数以适应未分类的数据。

您的代码似乎可以避免第1行中的文本列标题标签。我已经使用Range.CurrentRegion属性来定位要处理的单元格。

 Sub combineDelete() Const TEST_COLUMN As String = "A" Dim i As Long, mtch As Long 'appTGGL bTGGL:=False 'uncomment this line once you have completed debugging With ActiveSheet With .Cells(1, 1).CurrentRegion For i = .Rows.Count To 2 Step -1 mtch = Application.Match(.Cells(i, 1).Value, .Columns(1), 0) If mtch < i Then .Cells(mtch, 3) = Application.Sum(.Cells(mtch, 3), .Cells(i, 3)) .Cells(mtch, 4) = Application.Sum(.Cells(mtch, 4), .Cells(i, 4)) .Cells(mtch, 5) = Application.Sum(.Cells(mtch, 5), .Cells(i, 5)) End If Next i .RemoveDuplicates Columns:=1, Header:=xlYes End With End With appTGGL End Sub Public Sub appTGGL(Optional bTGGL As Boolean = True) With Application .ScreenUpdating = bTGGL .EnableEvents = bTGGL .DisplayAlerts = bTGGL .Calculation = IIf(bTGGL, xlCalculationAutomatic, xlCalculationManual) .StatusBar = vbNullString End With Debug.Print Timer End Sub 

Application.Sum(..., ...)的使用比直接添加要慢一些，但它具有对文本值进行错误控制的好处。 这可能是也可能不是一个理想的行为; 即你可能想知道什么时候你试图向一个数字添加文本而不是跳过它。

在With … End With语句中 ，有许多地方使用了Cells(i, 3)而不是.Cells(i, 3) （注意前缀）。 如果您要花时间引用Range.Parent属性 （并且您应该始终这样做！），那么不使用它就是一个耻辱。

我已经包含了一个可重用的“帮手”子，它closures了许多应用程序环境状态，但留下了评论。 一旦你完成debugging，取消注释，以提高速度和稳定性。

查找string的长度> 255的附录

 Sub combineDelete() Dim i As Long, mtch As Long Dim vCOLAs As Variant, dCOLAs As Object 'appTGGL bTGGL:=False 'uncomment this line once you have completed debugging Set dCOLAs = CreateObject("Scripting.Dictionary") dCOLAs.CompareMode = vbTextCompare With ActiveSheet With .Cells(1, 1).CurrentRegion 'strings in column A may exceed 255 chars; build array and and a dictionary from array vCOLAs = .Resize(.Rows.Count, 1).Value2 For i = UBound(vCOLAs, 1) To LBound(vCOLAs, 1) Step -1 'fast overwrite method dCOLAs.Item(vCOLAs(i, 1)) = i Next i For i = .Rows.Count To 2 Step -1 mtch = dCOLAs.Item(vCOLAs(i, 1)) If mtch < i Then .Cells(mtch, 3) = Application.Sum(.Cells(mtch, 3), .Cells(i, 3)) .Cells(mtch, 4) = Application.Sum(.Cells(mtch, 4), .Cells(i, 4)) .Cells(mtch, 5) = Application.Sum(.Cells(mtch, 5), .Cells(i, 5)) End If Next i .RemoveDuplicates Columns:=1, Header:=xlYes End With End With Erase vCOLAs dCOLAs.RemoveAll: Set dCOLAs = Nothing appTGGL End Sub 

字典对象由于其独特的键提供快速查找。 由于这些是变体types，因此不存在255个字符限制。