VBA “ Z ”形的累加统计 ( 有难度 )

On_fire

VBA “ Z ”形的累加统计 ( 有难度 )

*

Sheet1是源数据, AA, AB同行两列是要累加统计的数据

没参加计算的数据, 暂时删掉!

*

代码的逻辑如下,

1.       AA, AB两列由上到下, 先左后右, 一行又一行, 累加统计

2.      以“ Z ”形进行累加统计

3.      A65~A80的值是给的 ( 是变量? ), 代表要统计AA2, AB2两列往下多少行的范围?

4.      同时, 在同行C列往右, 输出累加结果

*

部分模拟结果( 如:1, 2, 6, 12行 )在Sheet1(2)

*

恳请大神们, 老师们, 出手帮忙…谢谢!

chxw68

1. Sub test()
   
2.     Dim r%, i%
   
3.     Dim arr, brr
   
4.     Dim d As Object
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     Set d1 = CreateObject("scripting.dictionary")
   
7.     With Worksheets("sheet1")
   
8.         r = .Cells(.Rows.Count, 27).End(xlUp).Row
   
9.         arr = .Range("aa2:ab" & r)
   
10.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
11.         brr = .Range("a65:a" & r)
    
12.         For i = 1 To UBound(brr)
    
13.             d1(brr(i, 1)) = i
    
14.         Next
    
15.         ReDim crr(1 To UBound(brr), 1 To 20)
    
16.         For i = 1 To UBound(arr)
    
17.             flg = i Mod 2
    
18.             For j = IIf(flg, 1, 2) To IIf(flg, 2, 1) Step IIf(flg, 1, -1)
    
19.                 d(arr(i, j)) = d(arr(i, j)) + 1
    
20.             Next
    
21.             If d1.exists(i) Then
    
22.                 m = d1(i)
    
23.                 n = 1
    
24.                 kk = Application.Transpose(Array(d.keys, d.items))
    
25.                 For x = 1 To UBound(kk) - 1
    
26.                     p = x
    
27.                     For y = x + 1 To UBound(kk)
    
28.                         If kk(p, 1) < kk(y, 1) Then
    
29.                             p = y
    
30.                         End If
    
31.                     Next
    
32.                     If p <> x Then
    
33.                         For q = 1 To 2
    
34.                             temp = kk(x, q)
    
35.                             kk(x, q) = kk(p, q)
    
36.                             kk(p, q) = temp
    
37.                         Next
    
38.                     End If
    
39.                 Next
    
40.                
    
41.                 For q = 1 To UBound(kk)
    
42.                     crr(m, n) = kk(q, 1) & "(" & kk(q, 2) & ")"
    
43.                     n = n + 1
    
44.                 Next
    
45.             End If
    
46.         Next
    
47.         
    
48.     End With
    
49.     With Worksheets("sheet2")
    
50.         .Range("c65").Resize(UBound(crr), UBound(crr, 2)) = crr
    
51.     End With
    
52.    
    
53. End Sub
    

复制代码

chxw68

详见附件。

你地铁图

参考一下111111

不知道为什么

chxw68 发表于 2023-4-19 19:12
详见附件。

有一段时间没经常来论坛了，看到褚老师风采依旧，开心

鄂龙蒙

Z.rar (20.82 KB, 下载次数: 10)

2023-4-19 20:21 上传

点击文件名下载附件

On_fire

鄂龙蒙 发表于 2023-4-19 20:21

早上好,
统一回复, 感谢各位大神, 老师….

gwjkkkkk

参与一下。。。

On_fire

gwjkkkkk 发表于 2023-4-20 20:37
参与一下。。。

老师好,
请问可以再帮忙优化一下代码,
需要判断每行两列括号()内的统计值,
如果右值比左值大, 要标黄( 模拟在Sheet1(4) )

gwjkkkkk

On_fire 发表于 2023-5-1 17:16
老师好,
请问可以再帮忙优化一下代码,
需要判断每行两列括号()内的统计值,

请参考 。。。