另类汇总，谢谢gwjkkkkk和shiruiqiang老师！

lhj323323

老师：



上传的附件里，有详细的说明。
求助.rar (16.3 KB, 下载次数: 5)

2024-11-18 16:59 上传

点击文件名下载附件

请看下图
汇总数据，是不含紫色区域的。


老师如有空，请帮忙看看
能否用字典来实现。

飞天篮球猪

仅供参考...

小凡、、、

gwjkkkkk

Option Explicit
Sub TEST2()
    Dim ar, br, i&, j&, k&, r&, n&
   
    Application.ScreenUpdating = False
   
    ar = [A1].CurrentRegion.Value
    ReDim br(1 To UBound(ar, 2), 1 To 4)
    For j = 1 To UBound(ar, 2) Step 4
        r = r + 1
        n = j - 1: br(r, 1) = ar(2, j)
        For i = 2 To UBound(ar)
            If ar(i, j) = br(r, 1) Then
                For k = 2 To 4
                    br(r, k) = br(r, k) + ar(i, n + k)
                Next k
            End If
        Next i
    Next j
   
    [af1].CurrentRegion.ClearContents
    [af1].Resize(, 4) = Array("日期", "A", "B", "R")
    [AF2].Resize(r, 4) = br
    Application.ScreenUpdating = True
    Beep
End Sub

lhj323323

小凡、、、 发表于 2024-11-18 18:45

谢谢老师！

测试成功了

能否抽空看看，我写的如下句，
If s = arr(i - 1, 1) Then
这一句，该如何修改？

1. Sub test()
   
2. Dim arr, d, i&, s$, m&
   
3. Application.ScreenUpdating = False
   
4. Set d = CreateObject("scripting.dictionary")
   
5. Sheet1.Activate
   
6. arr = [a1].CurrentRegion
   
7. ReDim crr(1 To UBound(arr), 1 To 2)
   
8. For i = 2 To UBound(arr)
   
9.     s = arr(i, 1)
   
10.     If s = arr(i - 1, 1) Then
    
11.        If d(s) = 0 Then
    
12.            m = m + 1
    
13.            d(s) = m
    
14.            crr(m, 1) = s
    
15.            crr(m, 2) = arr(i, 2)
    
16.        Else
    
17.            j = d(s)
    
18.            crr(j, 2) = crr(j, 2) + arr(i, 2)
    
19.        End If
    
20.     End If
    
21. Next
    
22. '[ak2].Resize(m, 2) = crr
    
23. [ak2].Resize(1, 2) = crr
    
24. Application.ScreenUpdating = True
    
25. End Sub

复制代码

gwjkkkkk

.............

shiruiqiang

下面代码结果

lhj323323

小凡、、、 发表于 2024-11-18 18:45

老师：
生成的结果，与我想实现的，还是有偏差
多提取了一些数据

lhj323323

gwjkkkkk 发表于 2024-11-18 19:19
.............

老师：
根据6楼的源码

运行后，仅有F列的统计有问题
但其它列却都是正确的
不知是何原因

求助3.rar (25.41 KB, 下载次数: 1)

2024-11-21 15:29 上传

点击文件名下载附件

gwjkkkkk

请参考附件。。。