我的问题是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
答案 0 :(得分：0)
此代码通过组合订单号和产品代码的字符串来匹配项目，进行计算并删除包含折扣的行。希望它适合你
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