多表汇总到本工作表

longer10010

求助，特定工作表外多表多区域汇总到本工作表

ykcbf1100

你这个复杂的，还多区域汇总。

3190496160

需要汇总的工作表内有很多个区域，究竟是需要如何汇总？汇总到那个工作表内？最好是有一个具体的说明，模拟一点结果，也许便于别人理解你的意图

longer10010

3190496160 发表于 2024-8-4 07:37
需要汇总的工作表内有很多个区域，究竟是需要如何汇总？汇总到那个工作表内？最好是有一个具体的说明，模拟 ...

汇总区域为对应填充颜色，除了特定工作表外其他工作表的数据汇总到自身工作表内

3190496160

longer10010 发表于 2024-8-5 08:51
汇总区域为对应填充颜色，除了特定工作表外其他工作表的数据汇总到自身工作表内

其他工作表的数据汇总到自身工作表内？？？？？？？？？？？？？

ykcbf1100

longer10010 发表于 2024-8-5 08:51
汇总区域为对应填充颜色，除了特定工作表外其他工作表的数据汇总到自身工作表内

附件供參考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.8.5
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     On Error Resume Next
   
5.     For Each sht In Sheets
   
6.         d.RemoveAll
   
7.         If Val(sht.Name) Then
   
8.             With sht
   
9.                 r = .Cells(Rows.Count, "m").End(3).Row
   
10.                 Arr = .[m1].Resize(r, 3)
    
11.                 ReDim brr(1 To r, 1 To 3)
    
12.                 m = 0
    
13.                 For i = 5 To UBound(Arr)
    
14.                     s = Trim(Arr(i, 1)) & "|" & Trim(Arr(i, 2))
    
15.                     If Len(s) > 2 Then
    
16.                         If Not d.exists(s) Then
    
17.                             m = m + 1
    
18.                             d(s) = m
    
19.                             brr(m, 1) = Arr(i, 1)
    
20.                             brr(m, 2) = Arr(i, 2)
    
21.                             brr(m, 3) = Arr(i, 3)
    
22.                         Else
    
23.                             r = d(s)
    
24.                             brr(r, 3) = brr(r, 3) + Arr(i, 3)
    
25.                         End If
    
26.                     End If
    
27.                 Next
    
28.                 .[b5:d29] = ""
    
29.                 .[b5].Resize(m, 3) = brr
    
30.                 '*****************************************
    
31.                 r = .Cells(Rows.Count, "w").End(3).Row
    
32.                 Arr = .[w1].Resize(r, 4)
    
33.                 ReDim brr(1 To r, 1 To 4)
    
34.                 m = 0
    
35.                 For i = 5 To UBound(Arr)
    
36.                     s = Trim(Arr(i, 1)) & "|" & Trim(Arr(i, 2)) & "|" & Trim(Arr(i, 4))
    
37.                     If Len(s) > 2 Then
    
38.                         If Not d.exists(s) Then
    
39.                             m = m + 1
    
40.                             d(s) = m
    
41.                             brr(m, 1) = Arr(i, 1)
    
42.                             brr(m, 2) = Arr(i, 2)
    
43.                             brr(m, 3) = Arr(i, 4)
    
44.                             brr(m, 4) = Arr(i, 3)
    
45.                         Else
    
46.                             r = d(s)
    
47.                             brr(r, 4) = brr(r, 4) + Arr(i, 3)
    
48.                         End If
    
49.                     End If
    
50.                 Next
    
51.                 .[b31:d40] = ""
    
52.                 .[b31].Resize(m, 4) = brr
    
53.                 '*****************************************
    
54.                 r = .Cells(Rows.Count, "ab").End(3).Row
    
55.                 Arr = .[ab1].Resize(r, 4)
    
56.                 ReDim brr(1 To r, 1 To 4)
    
57.                 m = 0
    
58.                 For i = 20 To UBound(Arr)
    
59.                     s = Trim(Arr(i, 1)) & "|" & Trim(Arr(i, 2)) & "|" & Trim(Arr(i, 3))
    
60.                     If Len(s) > 2 Then
    
61.                         If Not d.exists(s) Then
    
62.                             m = m + 1
    
63.                             d(s) = m
    
64.                             brr(m, 1) = Arr(i, 1)
    
65.                             brr(m, 2) = Arr(i, 2)
    
66.                             brr(m, 3) = Arr(i, 3)
    
67.                             brr(m, 4) = Arr(i, 4)
    
68.                         Else
    
69.                             r = d(s)
    
70.                             brr(r, 4) = brr(r, 4) + Arr(i, 4)
    
71.                         End If
    
72.                     End If
    
73.                 Next
    
74.                 .[g31:j40] = ""
    
75.                 .[g31].Resize(m, 4) = brr
    
76.             End With
    
77.         End If
    
78.     Next
    
79.     Set d = Nothing
    
80.     Application.ScreenUpdating = True
    
81.     MsgBox "OK！"
    
82. End Sub
    
83. 
    

复制代码

longer10010

3190496160 发表于 2024-8-5 08:57
其他工作表的数据汇总到自身工作表内？？？？？？？？？？？？？

对的！！！！！！！！！！！！！！

longer10010

ykcbf1100 发表于 2024-8-5 09:19
附件供參考。。。

非常感谢！！！！！