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

我在互联网上找到了以下代码，并对其稍作修改，但我的问题是它没有逻辑仅用于根据订单号组合重复项（相反，它用相同的值替换所有项目代码与订单号无关。）有没有办法添加代码以获取与给定订单号相似的所有项目代码并将它们相加？

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

    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