发出和收回数量排序并计算结果.谢谢

38180203

软件是WPS
同一张表,,把发出和收回的分别按名称来排序,,并计算出结果..谢谢
如果匹配不上的就往后面排
高手们有没有其他更好的方法吗,谢谢

半百

结果覆盖原表，请先备份原表。

ooluckydog

1. Option Explicit
   
2. 
   
3. Sub test()
   
4.     Const tbLeftColNum% = 9
   
5.     Const tbRightColNum% = 10
   
6.     Dim arr(), maxRowC%, maxRowL%, i&, m&, n&, leftQty&, rightQty&
   
7.     Dim dLeft As Object, dRight As Object, product
   
8.    
   
9.     Set dLeft = CreateObject("scripting.dictionary")
   
10.     Set dRight = CreateObject("scripting.dictionary")
    
11.    
    
12.     With Sheets("原表")
    
13.         maxRowC = .Cells(Rows.Count, "C").End(xlUp).Row
    
14.         maxRowL = .Cells(Rows.Count, "L").End(xlUp).Row
    
15.         
    
16.         For i = 3 To maxRowC
    
17.             product = .Cells(i, "C")
    
18.             If Not dLeft.exists(product) Then
    
19.                 Set dLeft(product) = New Collection
    
20.                 dLeft(product).Add .Cells(i, "A").Resize(1, tbLeftColNum).Value
    
21.             Else
    
22.                 dLeft(product).Add .Cells(i, "A").Resize(1, tbLeftColNum).Value
    
23.             End If
    
24.         Next
    
25.         
    
26.         For i = 3 To maxRowL
    
27.             product = .Cells(i, "L")
    
28.             If Not dRight.exists(product) Then
    
29.                 Set dRight(product) = New Collection
    
30.                 dRight(product).Add .Cells(i, "J").Resize(1, tbRightColNum).Value
    
31.             Else
    
32.                 dRight(product).Add .Cells(i, "J").Resize(1, tbRightColNum).Value
    
33.             End If
    
34.         Next
    
35.     End With
    
36.    
    
37.     With Sheets("需要的结果")
    
38.         .UsedRange.Offset(2).Clear
    
39.         m = 3: n = 3
    
40.         For Each product In dLeft.keys
    
41.             If dRight.exists(product) Then
    
42.                 leftQty = 0: rightQty = 0
    
43.                
    
44.                 For i = 1 To dLeft(product).Count
    
45.                     .Cells(m, "A").Resize(1, tbLeftColNum) = dLeft(product)(i)
    
46.                     leftQty = leftQty + dLeft(product)(i)(1, 6)
    
47.                     m = m + 1
    
48.                 Next
    
49.                 dLeft.Remove product
    
50.                
    
51.                 If dRight.exists(product) Then
    
52.                     For i = 1 To dRight(product).Count
    
53.                         .Cells(n, "J").Resize(1, tbRightColNum) = dRight(product)(i)
    
54.                         rightQty = rightQty + dRight(product)(i)(1, 4)
    
55.                         n = n + 1
    
56.                     Next
    
57.                     dRight.Remove product
    
58.                 End If
    
59.                
    
60.                 m = IIf(m > n, m, n) + 1: n = m
    
61.                 With .Cells(n - 1, "R")
    
62.                     .Value = rightQty - leftQty
    
63.                     .Font.Bold = True
    
64.                     .Interior.ColorIndex = 8
    
65.                 End With
    
66.             End If
    
67.         Next
    
68.         
    
69.         For Each product In dLeft.keys
    
70.             leftQty = 0
    
71.             For i = 1 To dLeft(product).Count
    
72.                 .Cells(n, "A").Resize(1, tbLeftColNum) = dLeft(product)(i)
    
73.                 leftQty = leftQty + dLeft(product)(i)(1, 6)
    
74.                 n = n + 1
    
75.             Next
    
76.             With .Cells(n, "R")
    
77.                 .Value = -leftQty
    
78.                 .Font.Bold = True
    
79.                 .Interior.ColorIndex = 8
    
80.             End With
    
81.             n = n + 1
    
82.         Next
    
83.         
    
84.         For Each product In dRight.keys
    
85.             rightQty = 0
    
86.             For i = 1 To dRight(product).Count
    
87.                 .Cells(n, "J").Resize(1, tbRightColNum) = dRight(product)(i)
    
88.                 rightQty = rightQty + dRight(product)(i)(1, 4)
    
89.                 n = n + 1
    
90.             Next
    
91.             With .Cells(n, "R")
    
92.                 .Value = rightQty
    
93.                 .Font.Bold = True
    
94.                 .Interior.ColorIndex = 8
    
95.             End With
    
96.             n = n + 1
    
97.         Next
    
98.     End With
    
99. 
    
100. End Sub
     

复制代码

38180203

半百 发表于 2024-5-8 13:31
结果覆盖原表，请先备份原表。

您好,老师,,显示下标越界

沈默00

38180203 发表于 2024-5-8 15:10
您好,老师,,显示下标越界

brr的下界放大一些，