求助按指定列的条件进行取数汇总

dagal

想将明细工作表内的M,O列有数字的所对应的A列的场所，进行汇总，附件中的汇总就是手工粘贴的结果，谢谢各位帮忙~

拨付明细表(1).rar (14.87 KB, 下载次数: 31)

2019-6-25 21:11 上传

点击文件名下载附件

灰色幽灵

<..........>

dagal

朱荣兴 发表于 2019-6-13 15:59
仅供参考
Sub hz() '''QQ:705664849
ReDim brr(1 To 10000, 1 To 18)

谢谢，不过取数的与我的附件有些差异，我是想把M、O列有数字的所对应的场所，整块提取过来，能否再帮忙看看，谢谢啦。

dagal

朱荣兴 发表于 2019-6-14 16:37
不明白你说的“整块”  是什么意思？？从来没见过这种说法

意思就是这两列有数据的时候，就把整个场所的信息都汇总到汇总表里，不只是提取有数据的那一行记录，不知这样表达能否说明我的意图，谢谢啦~

dagal

楼上版主在帮忙看看呗

dagal

谁能帮忙看看呀，谢谢啦。。。

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim d As Object
   
5.   Application.ScreenUpdating = False
   
6.   Application.DisplayAlerts = False
   
7.   Set d = CreateObject("scripting.dictionary")
   
8.   With Worksheets("明细")
   
9.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
10.     arr = .Range("a5:u" & r)
    
11.   End With
    
12.   For i = 1 To UBound(arr)
    
13.     If Not d.exists(arr(i, 1)) Then
    
14.       Set d(arr(i, 1)) = CreateObject("scripting.dictionary")
    
15.     End If
    
16.     If Not d(arr(i, 1)).exists(arr(i, 2)) Then
    
17.       m = 1
    
18.       ReDim brr(1 To UBound(arr, 2), 1 To m)
    
19.     Else
    
20.       brr = d(arr(i, 1))(arr(i, 2))
    
21.       m = UBound(brr, 2) + 1
    
22.       ReDim Preserve brr(1 To UBound(arr, 2), 1 To m)
    
23.     End If
    
24.     For j = 1 To UBound(arr, 2)
    
25.       brr(j, m) = arr(i, j)
    
26.     Next
    
27.     d(arr(i, 1))(arr(i, 2)) = brr
    
28.   Next
    
29.   With Worksheets("汇总")
    
30.     .UsedRange.Offset(4, 0).Clear
    
31.     m = 5
    
32.     For Each aa In d.keys
    
33.       m0 = m
    
34.       For Each bb In d(aa).keys
    
35.         brr = d(aa)(bb)
    
36.         ReDim crr(1 To UBound(brr, 2), 1 To UBound(brr))
    
37.         For i = 1 To UBound(brr)
    
38.           For j = 1 To UBound(brr, 2)
    
39.             crr(j, i) = brr(i, j)
    
40.           Next
    
41.         Next
    
42.         s = 0
    
43.         For j = 13 To 15 Step 2
    
44.           For i = 1 To UBound(crr)
    
45.             s = s + crr(i, j)
    
46.           Next
    
47.         Next
    
48.         If s > 0 Then
    
49.           .Cells(m, 1).Resize(UBound(crr), UBound(crr, 2)) = crr
    
50.           .Cells(m + UBound(crr), 5) = "小计"
    
51.           .Cells(m + UBound(crr), 6).Resize(1, 12).FormulaR1C1 = "=SUM(R" & m & "C:R[-1]C)"
    
52.           With .Cells(m + UBound(crr), 1).Resize(1, 20)
    
53.             With .Font
    
54.               .Bold = True
    
55.             End With
    
56.           End With
    
57.           For Each y In Array(1, 2, 3, 20)
    
58.             .Cells(m, y).Resize(1 + UBound(crr), 1).Merge
    
59.           Next
    
60.           m = m + UBound(crr) + 1
    
61.         End If
    
62.       Next
    
63.     Next
    
64.     With .Range("a3:t" & m - 1)
    
65.       .Borders.LineStyle = xlContinuous
    
66.       With .Font
    
67.         .Name = "宋体"
    
68.         .Size = 10
    
69.       End With
    
70.     End With
    
71.     With .Range("f5:q" & m - 1)
    
72.       .NumberFormatLocal = "#,##0.00_ "
    
73.       With .Font
    
74.         .Name = "Times New Roman"
    
75.       End With
    
76.     End With
    
77. 
    
78.   End With
    
79.       
    
80.    
    
81.    
    
82. End Sub
    

复制代码

chxw68

详见附件。