怎么用VBA汇总部门费用明细

wclle

求助各位大神，如附件，一个工作簿里面有很多张灰色的部门费用明细表，金额是分月份放的。现在的需求是，用VBA生成一个代码，如果 “名字明细"中A列的部门名字等于灰色工作表的名字，那么就将 ”名字明细“ 里面对应的B列费用名称的金额分月份的汇总到灰色部门去。比如 RO-COC的H37-H42=名字明细的I40-I44对应的费用名字金额。

kittli

新手路过，仅供参考！！

半百

请测试

ykcbf1100

附件供参考。。。

ykcbf1100

代码以附件为准

1. Sub ykcbf()  '//2024.1.31
   
2.     Set d = CreateObject("Scripting.Dictionary")
   
3.     Set sh = ThisWorkbook.Sheets("名字明细")
   
4.     With sh
   
5.         r = .Cells(Rows.Count, 1).End(3).Row
   
6.         arr = .Range("a1:n" & r)
   
7.         For i = 5 To 13
   
8.             s = arr(i, 1)
   
9.             If s <> Empty Then
   
10.                 For j = 3 To UBound(arr, 2)
    
11.                     ss = arr(i, 2) & "|" & Format(arr(4, j), "d-mmm")
    
12.                     If Not d.exists(s) Then Set d(s) = CreateObject("Scripting.Dictionary")
    
13.                     d(s)(ss) = arr(i, j)
    
14.                 Next
    
15.             End If
    
16.         Next
    
17.         For i = 18 To UBound(arr)
    
18.             s = arr(i, 1)
    
19.             If s <> Empty Then
    
20.                 For j = 3 To UBound(arr, 2)
    
21.                     ss = arr(i, 2) & "|" & Format(arr(17, j), "d-mmm")
    
22.                     If Not d.exists(s) Then Set d(s) = CreateObject("Scripting.Dictionary")
    
23.                     d(s)(ss) = arr(i, j)
    
24.                 Next
    
25.             End If
    
26.         Next
    
27.     End With
    
28.     For Each sht In Sheets
    
29.         If sht.Name <> sh.Name Then
    
30.             With sht
    
31.                 r = .Cells(Rows.Count, 1).End(3).Row
    
32.                 arr = .Range("a1:n" & r)
    
33.                 For i = 6 To UBound(arr)
    
34.                     s = .Name
    
35.                     If arr(i, 1) <> Empty And InStr(arr(i, 1), "TOTAL") = 0 Then
    
36.                         For j = 2 To UBound(arr, 2)
    
37.                             ss = arr(i, 1) & "|" & Format(arr(4, j), "d-mmm")
    
38.                             If d.exists(s) Then
    
39.                                 arr(i, j) = d(s)(ss)
    
40.                             End If
    
41.                         Next
    
42.                     End If
    
43.                 Next
    
44.                 .Range("a1:n" & r) = arr
    
45.             End With
    
46.         End If
    
47.     Next
    
48.     Set d = Nothing
    
49.     MsgBox "OK！"
    
50. End Sub
    

复制代码

wclle

kittli 发表于 2024-1-31 15:18
新手路过，仅供参考！！

测试OK，非常感谢，大神

wclle

半百 发表于 2024-1-31 18:47
请测试

可以达到目的，感谢大神

wclle

ykcbf1100 发表于 2024-1-31 21:05
附件供参考。。。

测试达到目的，十分感谢