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

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("a6:n" & r)
    
11.                 For i = 1 To UBound(arr)
    
12.                     If arr(i, 3) <> Empty And arr(i, 3) <> "小计" Then
    
13.                         s = Trim(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.         If k <> Empty Then
    
25.             m = m + 1
    
26.             brr(m, 1) = m
    
27.             brr(m, 2) = k
    
28.         End If
    
29.     Next
    
30.     With sh
    
31.         .UsedRange.Offset(4).Clear
    
32.         .[a3].Resize(m, 2) = brr
    
33.         arr = .[a1].Resize(m + 2, 15)
    
34.         For i = 3 To UBound(arr)
    
35.             For j = 2 To UBound(arr, 2) - 1
    
36.                 s = arr(2, j) & "|" & arr(i, 2)
    
37.                 If d.exists(s) Then
    
38.                     .Cells(i, j) = d(s)
    
39.                 End If
    
40.             Next
    
41.             .Cells(i, "o") = Application.WorksheetFunction.Sum(.Cells(i, 3).Resize(1, 12))
    
42.         Next
    
43.         .Cells(m + 3, 1) = "合计"
    
44.         .Cells(m + 3, 3).Resize(1, 13).FormulaR1C1 = "=SUM(R3C:R" & "[-1]C)"
    
45.         lr = 3
    
46.         r = .Cells(Rows.Count, 1).End(3).Row
    
47.         .Rows(lr & ":" & lr).Copy
    
48.         .Rows(lr + 1 & ":" & r).PasteSpecial Paste:=xlPasteFormats
    
49.         .Cells(m + 3, 1).Resize(1, 2).Merge
    
50.         .Cells(lr, 1).Select
    
51.         ActiveWindow.DisplayZeros = False
    
52.     End With
    
53.     Set d = Nothing
    
54.     Set d1 = Nothing
    
55.     Application.ScreenUpdating = False
    
56.     MsgBox "OK！"
    
57. End Sub
    

复制代码

longyi999

ykcbf1100 发表于 2024-5-24 13:32
代码更新一下。。。

谢谢大师帮我解决了燃眉之急！