VBA Excel：总和重复3个变量

Question

我的问题是针对VBA Excel。我有一个数据集与此类似：（编辑）

Order Number Description     Item Code Value 
AA000001  Mopping Service Payment 00001   100.00 
AA000001  Mopping Service Discount 00001   -50.00 
AA000001  Bucket Rental     00002    50.00 
AA000001  Bucket Rental Discount  00002   -25.00 
AA000001  Mopping Service Payment  00001    25.00 
AA000001  Bucket Rental     00002    10.00 
AA000002  Mopping Service Payment 00001   100.00 
AA000002  Mopping Service Discount 00001   -50.00 
AA000002  Bucket Rental     00002    50.00 
AA000002  Bucket Rental Discount  00002   -25.00 

我想输出什么：

Order Number Description     Item Code Value 
AA000001  Mopping Service Payment 00001    75.00 
AA000001  Bucket Rental     00002    35.00 
AA000002  Mopping Service Payment 00001    50.00 
AA000002  Bucket Rental     00002    25.00 

我发现在interwebs下面的代码，并修改了它略有下降，但我的问题是，它没有任何逻辑，只是基于订单号来组合重复项（相反，它将替换所有具有相同值的项目代码，而不考虑订单号）。是否有方法添加代码以获取所有对于一个给定的订单号码是相似的项目代码并将它们相加？

我需要添加什么？我错过了什么？提前致谢！

Dim Sh As Worksheet 
    Dim LastRow As Long 
    Dim Rng As Range 
    Set Sh = Worksheets(1) 
    Sh.Columns(5).Insert 
    LastRow = Sh.Range("A65536").End(xlUp).Row 
    With Sh.Range("A1:A" & LastRow).Offset(0, 4) 
     .FormulaR1C1 = "=IF(COUNTIF(R1C[-2]:RC[-2],RC[-2])>1,"""",SUMIF(R1C[-2]:R[" & LastRow & "]C[-2],RC[-2],R1C[-1]:R[" & LastRow & "]C[-1]))" 
     .Value = .Value 
    End With 
    Sh.Columns(4).Delete 
    Sh.Rows(1).Insert 
    Set Rng = Sh.Range("D1:D" & LastRow + 1) 
    With Rng 
     .AutoFilter Field:=1, Criteria1:="=" 
     .SpecialCells(xlCellTypeVisible).EntireRow.Delete 
    End With 

Answer 1

此代码通过组合订单号和产品代码字符串来匹配项目，进行计算并删除包含折扣的行。希望它能为你工作

Option Explicit 

Sub Combine__And__Delete() 

    Application.ScreenUpdating = False 
    Application.Calculation = xlCalculationManual 

    Dim ws As Worksheet 
    Set ws = Sheets(1) 

    Dim i&, j&, lr&, rng As Range, nrng As Range, str$, com$, x#, y# 
    lr = ws.Range("A" & Rows.Count).End(xlUp).Row 
    For i = 2 To lr 
     Set rng = ws.Range("A" & i): str = rng.Text & rng.Offset(0, 2).Text 
     For j = 2 To lr 
      If i <> j Then 
       Set nrng = ws.Range("A" & j): com = nrng.Text & nrng.Offset(0, 2).Text 
       If StrComp(str, com, 1) = 0 Then 
        x = CDbl(rng.Offset(0, 3)): y = CDbl(nrng.Offset(0, 3)) 
        If y < 0 Then 
         rng.Offset(0, 4) = CDbl(rng.Offset(0, 3)) - Abs(CDbl(nrng.Offset(0, 3))) 
        End If 
       End If 
       Set nrng = Nothing 
      End If 
     Next j 
     Set rng = Nothing 
    Next i 
    For i = lr To 2 Step -1 
     Set rng = ws.Range("E" & i) 
      If rng.Value < 0 Then Rows(rng.Row & ":" & rng.Row).Delete 
     Set rng = Nothing 
    Next i 
    Application.Calculation = xlCalculationAutomatic 
    Application.ScreenUpdating = True 
End Sub 

编辑：
我已经改变了代码一点，以更好地匹配您的条件。试试吧，留下的反馈:)

Option Explicit 

Sub Combine__And__Delete() 

    Application.ScreenUpdating = False 
    Application.Calculation = xlCalculationManual 

    Dim ws As Worksheet 
    Set ws = Sheets(1) 

    Dim i&, j&, lr&, rng As Range, str$, com$, tmp, x# 
    lr = ws.Range("A" & Rows.Count).End(xlUp).Row 
    ReDim arr(lr - 2) As String 
    For i = 2 To lr 
     Set rng = ws.Range("A" & i) 
     arr(i - 2) = rng.Text & "###" & rng.Offset(0, 2).Text 
     Set rng = Nothing 
    Next i 

    Call RemoveDuplicate(arr) 

    For i = LBound(arr) To UBound(arr) 
     For j = lr To 2 Step -1 
      Set rng = ws.Range("A" & j) 
      str = rng.Text & "###" & rng.Offset(0, 2).Text 
      If StrComp(str, arr(i), 1) = 0 Then 
       x = x + CDbl(rng.Offset(0, 3).Value) 
       com = rng.Offset(0, 1) 
      End If 
      Set rng = Nothing 
     Next j 
     arr(i) = arr(i) & "###" & CStr(x) & "###" & com 
     x = 0 
    Next i 

    Rows("2:" & lr).Delete 

    For i = LBound(arr) To UBound(arr) 
     Set rng = ws.Range("A" & i + 2) 
     tmp = Split(arr(i), "###") 
     rng = tmp(0) 
     rng.Offset(0, 1) = tmp(3) 
     rng.Offset(0, 2) = tmp(1) 
     rng.Offset(0, 3) = tmp(2) 
     Set rng = Nothing 
    Next i 

    Application.Calculation = xlCalculationAutomatic 
    Application.ScreenUpdating = True 
End Sub 


Sub RemoveDuplicate(ByRef StringArray() As String) 
    Dim lb&, ub&, TempArray() As String, cur&, A&, B& 
    If (Not StringArray) = True Then Exit Sub 
    lb = LBound(StringArray): ub = UBound(StringArray) 
    ReDim TempArray(lb To ub): cur = lb: TempArray(cur) = StringArray(lb) 
    For A = lb + 1 To ub 
     For B = lb To cur 
      If LenB(TempArray(B)) = LenB(StringArray(A)) Then 
       If InStrB(1, StringArray(A), TempArray(B), vbBinaryCompare) = 1 Then Exit For 
      End If 
     Next B 
     If B > cur Then cur = B: TempArray(cur) = StringArray(A) 
    Next A 
    ReDim Preserve TempArray(lb To cur): StringArray = TempArray 
End Sub