(VBA)如何删除重复行并将相应的值累加到右列? [英] (VBA) How to delete dupicate row and sum corresponding values to right columns?

问题描述

我有一个'test'excel，其中我有A-D的4列.如果A和B的值与另一行相同，则宏会删除较旧"的行，并将对应的值求和到C和D列中的另一行.

I have an 'test' excel where I have 4 columns from A-D. If A and B values are same with another row, macro deletes 'older' row and sums corresponding values to another row in to columns C and D.

      A | B | C | D                         A | B | C | D 

 1    1 | 2 | 1 | 5                         2 | 3 | 2 | 5
 2    2 | 3 | 2 | 5                         2 | 6 | 2 | 5
 3    2 | 6 | 2 | 5      After Macro        1 | 2 | 4 | 9
 4    1 | 2 | 3 | 4      --------->         5 | 4 | 1 | 2
 5    5 | 4 | 1 | 2

已编辑！因此，这里的第1行和第4行在A和B列上具有相同的值，因此宏会删除第1行，并将第1行的C D值添加到第4行的C D !!

EDITED! So here row 1 and row 4 had same values on columns A and B so macro deletes row 1 and adds row 1 column C D values to row 4 columns C D !!

我已经尝试过使用此代码，但现在它仅将值仅添加到D列，而不是C列.我真的不知道该怎么做.这是我的代码:

I have tried with this code, but now it only adds values only to column D and not also to column C.. I really dont know how to do it.. Here is my code:

    Private Sub CommandButton1_Click()

    Dim i As Long, lrk As Long, tmp As Variant, vals As Variant

        With Worksheets(1)
            tmp = .Range(.Cells(2, "A"), .Cells(Rows.Count, "D").End(xlUp)).Value2
            ReDim vals(LBound(tmp, 1) To UBound(tmp, 1), 1 To 1)
            For i = LBound(vals, 1) To UBound(vals, 1)
                vals(i, 1) = Application.SumIfs(.Columns(3), .Columns(1), tmp(i, 1), Columns(2), tmp(i, 2), Columns(3), tmp(i, 3), Columns(4), tmp(i, 4))

            Next i
            .Cells(2, "D").Resize(UBound(vals, 1), UBound(vals, 2)) = vals
            With .Cells(1, "A").CurrentRegion
                .RemoveDuplicates Columns:=Array(1, 2, 3, 4), Header:=xlYes
            End With
        End With
    End Sub

实际excel具有近2000行.因此，我也希望此宏足够快.感谢您的帮助，对不起我的英语.我希望你能理解:)

Actual excel has almost 2000 rows.. so I also hope this macro is fast enough for that. Thank you for your help and Im sorry for my English. I hope you understand :)

推荐答案

好的，答案很大程度上基于此我最近给出的答案.您可能想利用@DisplayName在同一线程中给出另一个聪明的答案，但这是我对使用类模块和字典的一种可理解的理解.

Oke, the answer is heavily based on this recent answer I have given. There is another clever answer in the same thread by @DisplayName that you might want to utilize, but here is my take on a understandable way of using a class module and a dictionary.

让我们假设从A1开始的以下输入数据:

Let's assume the following input data starting from A1:

| 1 | 2 | 1 | 5 |
| 2 | 3 | 2 | 5 |
| 2 | 6 | 2 | 5 |
| 1 | 2 | 3 | 4 |
| 5 | 4 | 1 | 2 |

首先创建一个class模块并命名，例如:clssList，其中包含以下代码:

First create a class module and name it, e.g.: clssList with the following code in it:

Public Col1 As Variant
Public Col2 As Variant
Public Col3 As Variant
Public Col4 As Variant

第二创建一个模块，并将以下代码放入其中:

Second create a module, and put the following code in it:

Sub BuildList()

Dim x As Long, arr As Variant, lst As clssList
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")

'Fill array variable from sheet
With Sheet1
    x = .Cells(.Rows.Count, 1).End(xlUp).Row
    arr = .Range("A1:D" & x).Value
End With

'Load array into dictionary with use of class
For x = LBound(arr) To UBound(arr)
    If Not dict.Exists(arr(x, 1) & "|" & arr(x, 2)) Then
        Set lst = New clssList
        lst.Col1 = arr(x, 1)
        lst.Col2 = arr(x, 2)
        lst.Col3 = arr(x, 3)
        lst.Col4 = arr(x, 4)
        dict.Add arr(x, 1) & "|" & arr(x, 2), lst
    Else 'In case column 2 is the same then add the values to the lst object
        dict(arr(x, 1) & "|" & arr(x, 2)).Col3 = dict(arr(x, 1) & "|" & arr(x, 2)).Col3 + arr(x, 3)
        dict(arr(x, 1) & "|" & arr(x, 2)).Col4 = dict(arr(x, 1) & "|" & arr(x, 2)).Col4 + arr(x, 4)
    End If
Next x

'Transpose dictionary into sheet3
With Sheet1
    x = 1
    For Each Key In dict.Keys
        .Cells(x, 6).Value = dict(Key).Col1
        .Cells(x, 7).Value = dict(Key).Col2
        .Cells(x, 8).Value = dict(Key).Col3
        .Cells(x, 9).Value = dict(Key).Col4
        x = x + 1
    Next Key
End With

End Sub

它有点广泛，但是我写的方式很容易理解发生了什么.可以快速保存2万条记录.

It's a bit extensive but I have written in such a way it will be easy to understand what is going on. It should be prety fast for 20000 records.

上面的结果是从范围F1开始的矩阵，如下所示:

The above results in a matrix starting from range F1 looking like:

对100.000行进行速度测试返回的总耗时约为3.4秒. 20.000条记录减少到大约1.8秒.

---

另一种较短的方法(编写代码，而不是提高速度)是不使用类模块并连接数组项(冒用的定界符存在于值中的风险很小).顶部的链接中显示了一个示例.我只是看到@RonRosenFeld提出了一个有关如何使用它的示例.

---

Another, shorter (written code, not speed) way would be to not use a class module and concatenate array items (with a small risk that the delimiter you will be using exists in a value). An example is shown in the link on the top. And I just see that @RonRosenFeld put an example up on how to use just that.

这篇关于(VBA)如何删除重复行并将相应的值累加到右列?的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！