VBA去重汇总并去除值为零的项

wagess

因数据有几千条且后续还要不断增加，请用VBA去重汇总并去除值为零的项
Sub aaaaa()
   Dim dic As Object, ii&, arr
    ii = Sheets("Sheet1").Range("a65536").End(xlUp).Row

    Set dic = CreateObject("Scripting.Dictionary")
    arr = Sheets("Sheet1").Range("a2:c" & ii)
    For ii = 1 To UBound(arr)
        'dic(arr(ii, 1)) = ii
       If arr(ii, 2) = "卖出" Then dic(arr(ii, 1)) = dic(arr(ii, 1)) - arr(ii, 3) Else dic(arr(ii, 1)) = dic(arr(ii, 1)) + arr(ii, 3)
    Next
    For Each k In dic.items
       If k = 0 Then dic.Remove (k)
   Next


    'For ii = 1 To dic.Count - 1
    '  If dic(arr(ii, 1)).items = 0 Then dic.Remove arr(ii, 1).Value   ' dic(arr(ii, 1)) = dic(arr(ii, 1)).Remove("dic(arr(ii, 1))")
   ' Next
    Sheets("Sheet1").Range("k2:l10").ClearContents
    Sheets("Sheet1").Range("k2").Resize(dic.Count) = WorksheetFunction.Transpose(dic.keys)
    Sheets("Sheet1").Range("l2").Resize(dic.Count) = WorksheetFunction.Transpose(dic.items)

End Sub
就卡在这里了
    For Each k In dic.items
       If k = 0 Then dic.Remove (k)
   Next

liulang0808

http://club.excelhome.net/thread-1385473-1-1.html
字典案例，楼主可以自己参考下

opel-wong

字典，循环，就可以完成，论坛上的例子太多了，
我都不想写了，，，

wagess

问题出在根据ITEMS值删除对应字典KEYS项上，论坛上找了很久没找到解决方法

opel-wong

wagess 发表于 2019-9-7 16:35
问题出在根据ITEMS值删除对应字典KEYS项上，论坛上找了很久没找到解决方法

你可以换个思路，数组循环，重新赋值到新数组，就可以了，  

opel-wong

习惯性动作，上传代码：

1. Sub 字典循环汇总数据()
   
2.     Dim d As Object, mRow As Long, arr, ZR(), i As Long, XR()
   
3.     Dim m As Long: m = 0: Dim h As Long: h = 0
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     With Sheet1
   
6.         .Activate
   
7.         mRow = .Range("A1048576").End(3).Row
   
8.         arr = .Range("A2:C" & mRow).Value
   
9.         ReDim ZR(1 To UBound(arr), 1 To 2)
   
10.         For i = 1 To UBound(arr)
    
11.             If arr(i, 1) <> "" Then
    
12.                 If InStr(arr(i, 2), "卖出") Then arr(i, 3) = Val(arr(i, 3)) * -1
    
13.                 If d.Exists(arr(i, 1)) Then
    
14.                     h = d(arr(i, 1))
    
15.                     ZR(h, 2) = ZR(h, 2) + Val(arr(i, 3))
    
16.                 Else
    
17.                     m = m + 1
    
18.                     d(arr(i, 1)) = m
    
19.                     ZR(m, 1) = arr(i, 1)
    
20.                     ZR(m, 2) = arr(i, 3)
    
21.                 End If
    
22.             End If
    
23.         Next
    
24.         ReDim XR(1 To UBound(ZR), 1 To 2)
    
25.         m = 0
    
26.         For i = 1 To UBound(ZR)
    
27.             If Val(ZR(i, 2)) <> 0 Then
    
28.                 m = m + 1
    
29.                 XR(m, 1) = ZR(i, 1)
    
30.                 XR(m, 2) = ZR(i, 2)
    
31.             End If
    
32.         Next
    
33.         With .Range("H2")
    
34.             .Resize(4 ^ 8, 2).ClearContents
    
35.             .Resize(d.Count, 2).Value = XR
    
36.         End With
    
37.     End With
    
38.     Set d = Nothing: Erase arr: Erase ZR: Erase XR
    
39. End Sub
    

复制代码

大灰狼1976

其他就不看了，就你卡住这一句，我来改一下试试。

1.     For Each k In dic.items
   
2.        If k = 0 Then dic.Remove (k)
   
3.    Next

复制代码

改成：

1.     For Each k In dic.keys
   
2.        If dic(k) = 0 Then dic.Remove (k)
   
3.     Next

复制代码

sheeboard

python pandas写的

1. import pandas as pd
   
2. import numpy as np
   
3. df=pd.read_excel('your_excel_file')                                                                                             
   
4. 
   
5. def to_nag(x,y):
   
6.     if x=='卖出':
   
7.         return -y
   
8.     else:
   
9.         return y
   
10. 
    
11. df['数量']=np.vectorize(to_nag)(df['摘要'],df['数量'])
    
12. grouped=df.groupby('名称')['数量'].sum()
    
13. result=grouped.reset_index()
    
14. result=result[result['数量']!=0]

复制代码

结果:

wagess

opel-wong 发表于 2019-9-7 16:58
习惯性动作，上传代码：

可能我的EXCEL版本太低，运行出错：对象不支持该属性

wagess

大灰狼1976 发表于 2019-9-7 17:01
其他就不看了，就你卡住这一句，我来改一下试试。

改成：

谢谢，问题完美解决