有条件汇总，谢谢cidanji、liulang0808和ykcbf1100老师！

lhj323323

老师：

上传的附件里
求助2.rar (16.16 KB, 下载次数: 5)

2024-8-29 12:44 上传

点击文件名下载附件

有写好的汇总语句
但却是【无条件】汇总

我想改为【有条件】汇总
如下图


老师如有空，请帮忙看看，先谢谢了。

wengjl

你的条件让人难以看懂，因为数据表上  无 日期，而你的条件那里有日期 。就汇总而言，是不难的！

cidanji

liulang0808

Sub test()
    Dim arr(), brr(), Arr2
    Dim myr%, i%, j%, m%
    Dim nL%, nRq%, Str$

Application.ScreenUpdating = False
Application.EnableEvents = False

With Sheet1
     Arr2 = .[a1].CurrentRegion
     myr = UBound(Arr2) - 1
     nL = UBound(Arr2, 2)
     nRq = (nL - 1) \ 3
     ReDim brr(1 To nRq * 2, 1 To 4)

      For j = 2 To nL Step 3 '从第2列开始向右历遍
          m = m + 1
          For i = 3 To myr '从第3行开始向下汇总
              If Arr2(i, j) > 0 And Arr2(i, j) >= brr(m, 1) Then
                 If Arr2(i, j) > brr(m, 1) Then
                    brr(m, 1) = Arr2(i, j)
                    brr(m, 2) = 0: brr(m, 3) = 0: brr(m, 4) = "3字头"
                    brr(m + 1, 1) = Arr2(i, j)
                    brr(m + 1, 2) = 0: brr(m, 3) = 0: brr(m + 1, 4) = "其他"
                    
                 End If
                 If Left(Arr2(i, 1), 1) = "3" Then
                    brr(m, 2) = brr(m, 2) + Arr2(i, j + 1)
                    brr(m, 3) = brr(m, 3) + Arr2(i, j + 2)
                 Else
                    brr(m + 1, 2) = brr(m + 1, 2) + Arr2(i, j + 1)
                    brr(m + 1, 3) = brr(m + 1, 3) + Arr2(i, j + 2)
                 End If



              End If
          Next
          m = m + 1
      Next
End With

'导入到结果表
With Sheet1
     .Range("s65536").End(xlUp).Offset(1, 0).Resize(nRq * 2, 4).Value = brr
End With
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub

liulang0808

建议楼主直接描述需求内容，而不是让别人读你的代码研究你的逻辑再去修改。

lhj323323

wengjl 发表于 2024-8-29 13:00
你的条件让人难以看懂，因为数据表上  无 日期，而你的条件那里有日期 。就汇总而言，是不难的！

不好意思，是我没介绍清楚
数据源里的B列和E列，就是日期

lhj323323

cidanji 发表于 2024-8-29 13:30

谢谢cidanji老师！

ykcbf1100

参与一下。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.8.29
   
2.     Set d = CreateObject("Scripting.Dictionary")
   
3.     With Sheets("数据源")
   
4.         r = .Cells(Rows.Count, 1).End(3).Row
   
5.         arr = .[a1].Resize(r, 7)
   
6.     End With
   
7.     ReDim brr(1 To r, 1 To 4)
   
8.     ReDim crr(1 To r, 1 To 4)
   
9.     For j = 2 To UBound(arr, 2) Step 3
   
10.         For i = 2 To UBound(arr)
    
11.             If arr(i, j) <> 0 Then
    
12.                 If Left(CStr(arr(i, 1)), 1) = "3" Then
    
13.                     s = arr(i, j) & "3开头"
    
14.                     If Not d.exists(s) Then
    
15.                         m = m + 1
    
16.                         d(s) = m
    
17.                         brr(m, 1) = arr(i, j)
    
18.                         brr(m, 2) = arr(i, j + 1)
    
19.                         brr(m, 3) = arr(i, j + 2)
    
20.                         brr(m, 4) = "3开头"
    
21.                     Else
    
22.                         r = d(s)
    
23.                         brr(m, 2) = brr(m, 2) + arr(i, j + 1)
    
24.                         brr(m, 3) = brr(m, 3) + arr(i, j + 2)
    
25.                     End If
    
26.                 Else
    
27.                     s = arr(i, j) & "其它"
    
28.                     If Not d.exists(s) Then
    
29.                         n = n + 1
    
30.                         d(s) = n
    
31.                         crr(n, 1) = arr(i, j)
    
32.                         crr(n, 2) = arr(i, j + 1)
    
33.                         crr(n, 3) = arr(i, j + 2)
    
34.                         crr(n, 4) = "其它"
    
35.                     Else
    
36.                         r = d(s)
    
37.                         crr(n, 2) = crr(n, 2) + arr(i, j + 1)
    
38.                         crr(n, 3) = crr(n, 3) + arr(i, j + 2)
    
39.                     End If
    
40.                 End If
    
41.             End If
    
42.         Next
    
43.     Next
    
44.     With Sheets("Sheet1")
    
45.         .[l2:o1000] = ""
    
46.         .[l2].Resize(m, 4) = brr
    
47.         r = .Cells(Rows.Count, "l").End(3).Row
    
48.         .Cells(r + 1, 12).Resize(n, 4) = crr
    
49.         Set Rng = .[l2].Resize(m + n, 4)
    
50.         Rng.Sort Rng.Columns(1), 1
    
51.     End With
    
52. End Sub
    
53. 
    

复制代码

lhj323323

cidanji 发表于 2024-8-29 13:30

cidanji老师

下图里的
m=m+2
为什么是加2呢？