Question

我有一个包含2列的Excel工作表，最多可以有15K行。我需要对值进行求和，按第一列和第二列进行分组。目前我正在使用followinn宏，代码是将数据复制到新工作表中，对其进行排序并删除重复项，同时添加计数（如果找到匹配项）。到目前为止，我已经测试了500行项目并且需要几分钟而且我担心如果有更多行所花费的时间（因为最多可以有15K行）。

Sub consolidateData()   

Dim lRow As Long   
Dim ItemRow1, ItemRow2 As String   
Dim lengthRow1, lengthRow2 As String   

    Columns("A:C").Select   
    Selection.Copy   

    Sheets("Sheet3").Select   

    Range("A1").Select   
    ActiveSheet.Paste   

    Cells.Select   
    Selection.Sort _   
        Key1:=Range("A2"), Order1:=xlAscending, _   
        Key2:=Range("C2"), Order2:=xlDescending, _   
        Header:=xlYes, OrderCustom:=1, _   
        MatchCase:=False, Orientation:=xlTopToBottom, _   
        DataOption1:=xlSortNormal   

    lRow = 2   
    Do While (Cells(lRow, 1) <> "")   

        ItemRow1 = Cells(lRow, "A")   
        ItemRow2 = Cells(lRow + 1, "A")   

        lengthRow1 = Cells(lRow, "C")   
        lengthRow2 = Cells(lRow + 1, "C")   

        If ((ItemRow1 = ItemRow2) And (lengthRow1 = lengthRow2)) Then   
            Cells(lRow, "B") = Cells(lRow, "B") + Cells(lRow + 1, "B")   
            Rows(lRow + 1).Delete   

        Else   
            lRow = lRow + 1   
        End If   
    Loop   
End Sub

您能否建议是否有最快捷的方法。提前致谢。

Answer 1

Thera是您为改善表现而采取的一些措施：

从SOF Delete all duplicate row开始，您可以使用 RemoveDuplica 方法：

    Sub DeleteRows()
        With ActiveSheet
          Set Rng = Range("A1", Range("B1").End(xlDown))
          Rng.RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes
        End With
    End Sub

如果您使用预先格式化的表格，则可以轻松填写包含所需信息的新表格

如果合适，请始终使用以下代码来改善您的功能/子功能：

    Application.ScreenUpdating = False

如果只复制应按其分组的列，则可能会更好，然后将 sumif 复制到值列中。

希望它有用。

Answer 2

这是让您的宏更快的快速方法。它会停止动画和其他一些额外的好处。 :) 但是，从一开始就重建代码是一个好主意，避免选择。

@ExceptionHandler

Excel - 按列分组的宏＆amp;大范围（15K行）的总和值

2 个答案: