[已解决]Excel VBA按多个条件删除行（求助高手）

fxb2015

要求见附件“材料统计.rar”的excel表中有说明（为了把VBA代码需求说的更详细，在2楼有详细补充），恳切有劳各位老师帮忙解决！

最佳答案

月排行榜 / 总排行榜

grf1973

2015-12-29 14:14

按8楼思路弄的代码。我觉得总的原则是对冲掉尽可能多的行。

1. Sub 统计()
   
2.     arr = Sheet1.[a1].CurrentRegion.Offset(1)
   
3.     Set df = CreateObject("scripting.dictionary")        '记录相同物资的负值
   
4.     Set ddf = CreateObject("scripting.dictionary")        '记录相同物资的负值的行
   
5.     Set dz = CreateObject("scripting.dictionary")        '记录相同物资的最小正值
   
6.     Set ddz = CreateObject("scripting.dictionary")        '记录相同物资的最小正值的行
   
7.     Set d = CreateObject("scripting.dictionary")        '记录需要删除的行
   
8.     Set sy = CreateObject("scripting.dictionary")        '记录所有key
   
9.     For i = 2 To UBound(arr)
   
10.         x = arr(i, 7) & arr(i, 9) & arr(i, 11) '以名称+计量单位+单价 为key
    
11.         If Len(x) > 0 Then
    
12.             sy(x) = ""        '所有key
    
13.             sl = arr(i, 10)  '数量
    
14.             If sl < 0 Then          '数量小于0
    
15.                 df(x) = df(x) + sl
    
16.                 ddf(x) = ddf(x) & "," & i
    
17.             ElseIf sl > 0 Then    '数量大于0
    
18.                 dz(x) = dz(x) + sl
    
19.                 ddz(x) = ddz(x) & "," & i
    
20.             Else       '数量等于0，直接进删除字典
    
21.                 d(x) = d(x) & "," & i
    
22.             End If
    
23.         End If
    
24.     Next
    
25.    
    
26.     For Each x In sy.keys
    
27.         frr = Split(ddf(x), ",")
    
28.         zrr = Split(ddz(x), ",")
    
29.         If UBound(frr) >= 1 And UBound(zrr) >= 1 Then     '有正负数才开始消除
    
30.             If UBound(frr) > 1 Then
    
31.                 For i = 1 To UBound(frr) - 1        '负值数量从大到小排序
    
32.                     For j = i + 1 To UBound(frr)
    
33.                         If arr(frr(i), 10) < arr(frr(j), 10) Then tmp = frr(i): frr(i) = frr(j): frr(j) = tmp
    
34.                     Next
    
35.                 Next
    
36.             End If
    
37.             If UBound(zrr) > 1 Then
    
38.                 For i = 1 To UBound(zrr) - 1        '正值数量从小到大排序
    
39.                     For j = i + 1 To UBound(zrr)
    
40.                         If arr(zrr(i), 10) > arr(zrr(j), 10) Then tmp = zrr(i): zrr(i) = zrr(j): zrr(j) = tmp
    
41.                     Next
    
42.                 Next
    
43.             End If
    
44.             zs = dz(x): fs = df(x) '正负数
    
45.             If zs >= Abs(fs) Then    '正数大于等于负数
    
46.                 For i = 1 To UBound(frr)         '负值行全部消除
    
47.                     d(Val(frr(i))) = ""
    
48.                 Next
    
49.                 tmp = 0
    
50.                 For i = 1 To UBound(zrr)    '正值行消除到最后一个去余值
    
51.                     k = Val(zrr(i))
    
52.                     tmp = tmp + arr(k, 10)
    
53.                     If tmp <= Abs(fs) Then
    
54.                         d(k) = ""
    
55.                     Else
    
56.                         arr(k, 10) = tmp + fs: Exit For
    
57.                     End If
    
58.                 Next
    
59.             Else                     '正数小于负数
    
60.                 For i = 1 To UBound(zrr)         '负值行全部消除
    
61.                     d(Val(zrr(i))) = ""
    
62.                 Next
    
63.                 tmp = 0
    
64.                 For i = 1 To UBound(frr)        '负值行消除到最后一个去余值
    
65.                     k = Val(frr(i))
    
66.                     tmp = tmp + arr(k, 10)
    
67.                     If Abs(tmp) <= zs Then
    
68.                         d(k) = ""
    
69.                     Else
    
70.                         arr(k, 10) = tmp + zs: Exit For
    
71.                     End If
    
72.                 Next
    
73.             End If
    
74.         End If
    
75.     Next
    
76.             
    
77.     ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))         '把未删除的行保留
    
78.     For i = 1 To UBound(arr)
    
79.         If Not d.exists(i) Then
    
80.             n = n + 1
    
81.             For j = 1 To UBound(arr, 2)
    
82.                 brr(n, j) = arr(i, j)
    
83.             Next
    
84.         End If
    
85.     Next
    
86.     With Sheets(3)        '结果显示
    
87.         .Cells.Clear
    
88.         .[a1].Resize(n, UBound(arr, 2)) = brr
    
89.         .Activate
    
90.     End With
    
91. End Sub
    

复制代码

跳转到最佳答案楼层

fxb2015

附件可在1楼下载“材料统计.rar”~~~~~~~
【要求如下】用Excel  VBA代码达到以下要求，希望就在工作表“材料表”中执行VBA删除行代码，在工作表“材料表”左上角有个命令为“统计”按钮，可指定宏：
当“物资名称(G列)、计量单位(I列)、单价(K列) ”三者都相同的物资（即以G列、I列、J列并为一个关键字），然后对“数量(J列) ”进行统计，规则如下：
   （1）当J列（J3:J区域）所有负值之和与所有正值中的最小正值相加大于零时，用所有负值之和与最小正值相加，并把结果保留在最小正值这一单元格（该行与其他正值的行保留），并删掉所有负值的行。
      [示例]如物资CC（所有负值之和与所有正值中的最小正值相加-3-1+8=4＞0，数量为8的单元格变为4且该行保留，数量为-3、-1这2行删除，数量为11的这一行也保留）。

   （2）当J列（J3:J区域）所有负值之和与所有正值中的最小正值相加等于零时，删掉所有负值行和该最小正值行，其余正值的行保留。
      [示例]如物资AA（所有负值之和与所有正值中的最小正值相加-0.2-0.3+0.5=0，则数量为0.5、-0.2、-0.3这三行删除，数量为1.2的这一行保留）。

   （3）当J列（J3:J区域）所有负值之和与所有正值中的最小正值相加小于零时，又分四种情况如下：
           ①如有单行负值等于单行正值时，优先删掉该正值行和该负值行，同时用余下的负值之和，依次与剩下的所有正值的数值从小到大进行累加，直到相加之和大于零，然后把相加后大于零的这个值替换掉这个正数并保留该行，并把这个正数之前的所有正数行以及所有负数行删掉。
             [示例]如物资FF（所有负值之和与所有正值中的最小正值相加-8-2-1+4=-7＜0,则数量为8和-8这两行先删除，同时用用余下的负值之和，依次与所有正值的数值从小到大进行累加，直到相加之和大于零（-2-1+4=1＞0），然后大于零的这个值替换掉这个正数并保留该行（即数量4变为1且保留该行），并把这个正数之前的所有正数行以及所有负数行删掉）。
           ②如存在所有负值之和等于所有正值中的任意一个正值时，所有负值行和该正值行删掉,其余正值的行保留。
             [示例]如物资EE（所有负值之和与所有正值中的最小正值相加-9-3+8=-4＜0,且-9-3+12=0，则数量12、-9、-3这三行删除，数量8和数量22这两行保留。
           ③如存在所有负值之和与所有正值之和相加等于零时，所有正值行与所有负值行删除。
             [示例]如物资BB（所有负值之和与所有正值中的最小正值相加-8-7+6=-9＜0,且6+9-8-7=0，则数量6、9、-8、-7这4行删除）。
            另外，如存在任意几个负值之和与任意几个正值之和相加等于零时，那么这些负值行和正值行均删除，同时用余下的负值之和，依次与剩下的所有正值的数值从小到大进行累加，直到相加之和大于零，然后把相加后大于零的这个值替换掉这个正数并保留该行，再把负值的行删掉。
             [示例]如物资GG（所有负值之和与所有正值中的最小正值相加-8-7+6=-9＜0,且6+9-8-7=0，则数量6、9、-8、-7这4行删除,同时余下的负数与剩下则正数相加-10+12=2，数量12变为2并保留该行，进而也删除数量-10这一行。
           ④如果以上①②③情况都存在——那就先执行情况①，再执行情况②，最后执行情况③。如果以上①②③情况都不存在时，就用所有负值之和，依次与所有正值的数值从小到大进行累加，直到相加之和大于零，然后把相加后大于零的这个值替换掉这个正数并保留该行，并把这个正数之前的所有正数行以及所有负数行删掉。
             [示例]物资DD（所有负值之和与所有正值中的最小正值相加-14-2+1=-15＜0,用所有负值之和依次与所有正值的数值从小到大进行累加到10这个数大于零-2-14+1+8+10=3＞0，然后大于零的这个值3替换掉这个正数10并保留该行，并把这个正数之前的所有正数行1、8两行以及所有负数行-2、-14两行删掉，数量11的这一行也保留。

  当然，这仅仅只是举例（只有物资AA、物资BB、物资CC、物资DD、物资EE、物资FF、物资GG），还有更多的物资（如物资HH、物资II、物资JJ等）会出现以上（1）、（2）、（3）这三种情况。

【最终效果】见本工作薄的“材料合计”工作表。工作表“材料表”天蓝色背景色的行均保留，有黄色背景色的行均被删除。

七彩屋

这么多要求，要花多少时间啊

fxb2015

七彩屋 发表于 2015-12-28 17:53
这么多要求，要花多少时间啊

别看要求的文字那么多——只是为了描述的更仔细！其实，条件限制也不复杂的，就是在（1）、（2）、（3）这3个条件下进行删除行，当然条件（3）又有4个小分支条件。

fxb2015

貌似这个问题比较难，恳求Excel VBA代码高手老师们帮忙解决下啊

fxb2015

我有一个思路（VBA代码）：
用数组法或字典法从第三行起把G列、I列、J列并为一个关键字，然后删掉重复关键而留下不重复关键字，然后对每一个不重复关键字对J列进行所有负数求和（设为x）、正数求和（设为y），同时找出每一个关键字所有正数中的最小正数（设为z）：
（1）如果x+z=m>0，就删掉该关键字的所有负数行，把z改为m并保留该行，其余正值行保留。
（2）如果x+z=n=0，就删掉该关键字的所有负数行，删掉最小正数z这一行，其余正值行保留。
（3）如果x+z=p<0，则分为以下情况：
      <1>   查找 该关键字的所有负数行，如有一个负数与所有正数行的任一个正数相加等于零，那么删掉该负数行和正数行。其余行保留。
      <2>   用x与所有正数的任一正数相加等于零，则删掉所有负数行和该正数行，其余行保留。
      <3>   如果x+y=0，则删掉所有正数行和所有负数行。当然，所有负数中的任意几个负数之和与所有正数中的任意几个正数之和相加等于零，那么这任意几个负数行、任意几个正数行全部删掉，其余行保留。
      <4>   如果每一个关键字同时出现<1>、<2>、<3> 这三种情况，先执行<1>，再执行<2>，最后执行<3> 。
               要是<1>、<2>、<3>都不出现，则用所有正数行的正数按从小打到进行累加，比如正数q1<q2<q3<q4......，那么用q1+q2+x=j1，q1+q2+q3+x=j2，q1+q2+q3+q4+x=j3，如果j1、j2、j3中j2大于零时，则把q3改为j2并保留该行（q4行也保留），q1和q2这两行、所有负数行删掉。

grf1973

第一第二都好办，第三分四种情况实在复杂。应该有更好的表述方法。

grf1973

看看能不能表述成这样。
以G列、I列、J列并为一个关键字，然后对关键字对J列进行所有负数求和（设为x）、正数求和（设为y）
（1）如果x+y=0，就删掉该关键字的所有行
（2）如果x+y>0，表示正数多于负数，就删掉该关键字的所有负数行，正数行按数量从小到大删除，直到删除的行数量累加为x；如果不能正好抵消，最后一行减去余值
（3）如果x+y<0，表示负数多于正数，就删掉该关键字的所有正数行，负数行按数量从大到小删除，直到删除的行数量累加为y；如果不能正好抵消，最后一行减去余值

grf1973

按8楼思路弄的代码。我觉得总的原则是对冲掉尽可能多的行。

1. Sub 统计()
   
2.     arr = Sheet1.[a1].CurrentRegion.Offset(1)
   
3.     Set df = CreateObject("scripting.dictionary")        '记录相同物资的负值
   
4.     Set ddf = CreateObject("scripting.dictionary")        '记录相同物资的负值的行
   
5.     Set dz = CreateObject("scripting.dictionary")        '记录相同物资的最小正值
   
6.     Set ddz = CreateObject("scripting.dictionary")        '记录相同物资的最小正值的行
   
7.     Set d = CreateObject("scripting.dictionary")        '记录需要删除的行
   
8.     Set sy = CreateObject("scripting.dictionary")        '记录所有key
   
9.     For i = 2 To UBound(arr)
   
10.         x = arr(i, 7) & arr(i, 9) & arr(i, 11) '以名称+计量单位+单价 为key
    
11.         If Len(x) > 0 Then
    
12.             sy(x) = ""        '所有key
    
13.             sl = arr(i, 10)  '数量
    
14.             If sl < 0 Then          '数量小于0
    
15.                 df(x) = df(x) + sl
    
16.                 ddf(x) = ddf(x) & "," & i
    
17.             ElseIf sl > 0 Then    '数量大于0
    
18.                 dz(x) = dz(x) + sl
    
19.                 ddz(x) = ddz(x) & "," & i
    
20.             Else       '数量等于0，直接进删除字典
    
21.                 d(x) = d(x) & "," & i
    
22.             End If
    
23.         End If
    
24.     Next
    
25.    
    
26.     For Each x In sy.keys
    
27.         frr = Split(ddf(x), ",")
    
28.         zrr = Split(ddz(x), ",")
    
29.         If UBound(frr) >= 1 And UBound(zrr) >= 1 Then     '有正负数才开始消除
    
30.             If UBound(frr) > 1 Then
    
31.                 For i = 1 To UBound(frr) - 1        '负值数量从大到小排序
    
32.                     For j = i + 1 To UBound(frr)
    
33.                         If arr(frr(i), 10) < arr(frr(j), 10) Then tmp = frr(i): frr(i) = frr(j): frr(j) = tmp
    
34.                     Next
    
35.                 Next
    
36.             End If
    
37.             If UBound(zrr) > 1 Then
    
38.                 For i = 1 To UBound(zrr) - 1        '正值数量从小到大排序
    
39.                     For j = i + 1 To UBound(zrr)
    
40.                         If arr(zrr(i), 10) > arr(zrr(j), 10) Then tmp = zrr(i): zrr(i) = zrr(j): zrr(j) = tmp
    
41.                     Next
    
42.                 Next
    
43.             End If
    
44.             zs = dz(x): fs = df(x) '正负数
    
45.             If zs >= Abs(fs) Then    '正数大于等于负数
    
46.                 For i = 1 To UBound(frr)         '负值行全部消除
    
47.                     d(Val(frr(i))) = ""
    
48.                 Next
    
49.                 tmp = 0
    
50.                 For i = 1 To UBound(zrr)    '正值行消除到最后一个去余值
    
51.                     k = Val(zrr(i))
    
52.                     tmp = tmp + arr(k, 10)
    
53.                     If tmp <= Abs(fs) Then
    
54.                         d(k) = ""
    
55.                     Else
    
56.                         arr(k, 10) = tmp + fs: Exit For
    
57.                     End If
    
58.                 Next
    
59.             Else                     '正数小于负数
    
60.                 For i = 1 To UBound(zrr)         '负值行全部消除
    
61.                     d(Val(zrr(i))) = ""
    
62.                 Next
    
63.                 tmp = 0
    
64.                 For i = 1 To UBound(frr)        '负值行消除到最后一个去余值
    
65.                     k = Val(frr(i))
    
66.                     tmp = tmp + arr(k, 10)
    
67.                     If Abs(tmp) <= zs Then
    
68.                         d(k) = ""
    
69.                     Else
    
70.                         arr(k, 10) = tmp + zs: Exit For
    
71.                     End If
    
72.                 Next
    
73.             End If
    
74.         End If
    
75.     Next
    
76.             
    
77.     ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))         '把未删除的行保留
    
78.     For i = 1 To UBound(arr)
    
79.         If Not d.exists(i) Then
    
80.             n = n + 1
    
81.             For j = 1 To UBound(arr, 2)
    
82.                 brr(n, j) = arr(i, j)
    
83.             Next
    
84.         End If
    
85.     Next
    
86.     With Sheets(3)        '结果显示
    
87.         .Cells.Clear
    
88.         .[a1].Resize(n, UBound(arr, 2)) = brr
    
89.         .Activate
    
90.     End With
    
91. End Sub
    

复制代码

grf1973

代码第21句应改成 d(i)=""
上楼代码运行结果和你模拟结果相同。