怎么历遍工作表，然后根据汇总表的字段汇总金额并填入汇总表里

ykcbf1100

goodlzy 发表于 2024-12-23 16:53
根据您后面的给的代码，可以了。但是您的代码是复制数据过去，因为是汇总表所以目标是汇总相应字段的汇总 ...

改好了。。。

ykcbf1100

排重汇总。。。

1. Sub 汇总()    '//2024.12.23
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Set d1 = CreateObject("Scripting.Dictionary")
   
5.     Set sh = ThisWorkbook.Sheets("汇总表")
   
6.     With sh
   
7.         c1 = .UsedRange.Columns.Count
   
8.         ReDim brr(1 To 10000, 1 To c1)
   
9.         For j = 1 To c1
   
10.             s = .Cells(2, j).Value
    
11.             d1(s) = j
    
12.         Next
    
13.     End With
    
14.     On Error Resume Next
    
15.     For Each sht In Sheets
    
16.         If InStr("基本信息|汇总表|录入界面", sht.Name) = 0 Then
    
17.             With sht
    
18.                 r = .Cells(Rows.Count, 1).End(3).Row
    
19.                 c = .UsedRange.Columns.Count
    
20.                 arr = .[a1].Resize(r, c)
    
21.                 For i = 3 To UBound(arr)
    
22.                     s = arr(i, d1("推广者姓名"))
    
23.                     If Not d.exists(s) Then
    
24.                         m = m + 1
    
25.                         d(s) = m
    
26.                         For j = 1 To UBound(arr, 2)
    
27.                             s1 = arr(2, j)
    
28.                             If d1.exists(s1) Then
    
29.                                 brr(m, d1(s1)) = arr(i, j)
    
30.                             End If
    
31.                         Next
    
32.                     Else
    
33.                         r = d(s)
    
34.                         For j = 4 To UBound(arr, 2)
    
35.                             s1 = arr(2, j)
    
36.                             If InStr(LCase(s1), "id") = 0 Then
    
37.                                 If d1.exists(s1) Then
    
38.                                     If Val(arr(i, j)) Then
    
39.                                         brr(r, d1(s1)) = brr(r, d1(s1)) + arr(i, j)
    
40.                                     End If
    
41.                                 End If
    
42.                             End If
    
43.                         Next
    
44.                     End If
    
45.                 Next
    
46.             End With
    
47.         End If
    
48.     Next
    
49.     With sh
    
50.         .UsedRange.Offset(2).ClearContents
    
51.         .[a3].Resize(m, c1) = brr
    
52.     End With
    
53.     Set d = Nothing
    
54.     Application.ScreenUpdating = True
    
55.     MsgBox "OK！"
    
56. End Sub
    
57. 
    

复制代码

gwjkkkkk

请参考。。。

cai2532

这个很实用。

gwjkkkkk

参与一下。。。

goodlzy

好用很实用，非常感谢。