江湖帮扶！如何将多张工作表中的部分内容汇总到一张工作表中?感谢！

longyi999

哪位大侠过路帮扶下！如何将工作薄中 多张工作表中的姓名和相应总金额 汇总到 发放汇总表中? 请老师修改哈，万分感谢！！

shiruiqiang

遍历工作表，姓名和表名做字典，总额是字典值就行

沈默00

你的多张工作表在哪呢？？

3190496160

总金额在分表中哪一列？？？？？

shiruiqiang

沈默00 发表于 2024-5-24 07:23
你的多张工作表在哪呢？？

有3张隐藏的表

ykcbf1100

罚款要加进去吗？

ykcbf1100

附件更新一下。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.5.24
   
2.     Dim arr, brr, s
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Set d1 = CreateObject("Scripting.Dictionary")
   
5.     Set sh = ThisWorkbook.Sheets("奖金发放汇总表")
   
6.     For Each sht In Sheets
   
7.         If Val(sht.Name) Then
   
8.             With sht
   
9.                 r = .Cells(Rows.Count, 3).End(3).Row
   
10.                 arr = .Range("a26:n" & r)
    
11.                 For i = 1 To UBound(arr)
    
12.                     If arr(i, 3) <> Empty Then
    
13.                         s = arr(i, 1)
    
14.                         d1(s) = ""
    
15.                         s = .Name & "|" & arr(i, 1)
    
16.                         d(s) = Application.WorksheetFunction.Round(arr(i, 13), 2)
    
17.                     End If
    
18.                 Next
    
19.             End With
    
20.         End If
    
21.     Next
    
22.     ReDim brr(1 To d.Count, 1 To 2)
    
23.     For Each k In d1.keys
    
24.         m = m + 1
    
25.         brr(m, 1) = m
    
26.         brr(m, 2) = k
    
27.     Next
    
28.     With sh
    
29.         .[a3].Resize(m, 2) = brr
    
30.         .UsedRange.Offset(3 + m).Clear
    
31.         arr = .[a1].Resize(m + 2, 15)
    
32.         For i = 3 To UBound(arr)
    
33.             For j = 2 To UBound(arr, 2) - 1
    
34.                 s = arr(2, j) & "|" & arr(i, 2)
    
35.                 If d.exists(s) Then
    
36.                     .Cells(i, j) = d(s)
    
37.                 End If
    
38.             Next
    
39.             .Cells(i, "o") = Application.WorksheetFunction.Sum(.Cells(i, 3).Resize(1, 12))
    
40.         Next
    
41.         .Cells(m + 3, 1) = "合计": .Cells(m + 3, 1).Resize(1, 2).Merge
    
42.         .Cells(m + 3, 3).Resize(1, 13).FormulaR1C1 = "=SUM(R3C:R" & "[-1]C)"
    
43.         ActiveWindow.DisplayZeros = False
    
44.     End With
    
45.     Set d = Nothing
    
46.     Set d1 = Nothing
    
47.     Application.ScreenUpdating = False
    
48.     MsgBox "OK！"
    
49. End Sub
    

复制代码

longyi999

ykcbf1100 发表于 2024-5-24 08:54
附件供参考。。。

感谢大神，但在汇总表丢掉了A6-A13中5个人的统计，代码还得麻烦援手修改哈

ykcbf1100

longyi999 发表于 2024-5-24 11:48
感谢大神，但在汇总表丢掉了A6-A13中5个人的统计，代码还得麻烦援手修改哈

改好了。。。