工作簿内的多表标题位置不定如何按标题及姓名汇总

jjmysjg

提取各分表“施工人”标题下面的不重复姓名到汇总表的A2向下，对应的“方量”等9列字段的数值求和放入汇总表对应字段项目。
数据源行数不定。
分表各个标题行列位置不定。
附件的代码是按时间格式汇总的代码，现在把时间改为姓名了，代码怎么修改。
谢谢各位老师！

liulang0808

Sub 按钮1_Click()
    Set d = CreateObject("scripting.dictionary")
    Set dd = CreateObject("scripting.dictionary")
    Application.ScreenUpdating = False
    Sheets("汇总").UsedRange.Offset(1).ClearContents
    arr = Sheets("汇总").[a1].Resize(9999, 11)
    arr(1, 1) = "施工人"
    r = 1
    For Each sh In Sheets
        If sh.Name <> "汇总" Then
            Set Rng = sh.UsedRange.Find("施工人", lookat:=xlWhole)
            If Not Rng Is Nothing Then
                d(arr(1, 1)) = Rng.Column
                rx = Rng.Row
                brr = sh.UsedRange
                For j = 2 To 10
                    For i = 1 To UBound(brr, 2)
                        If arr(1, j) = brr(rx, i) Then
                            d(arr(1, j)) = i
                            Exit For
                        End If
                    Next i
                Next j
                For j = 1 To UBound(brr)
                    nm = brr(j, d(arr(1, 1)))
                    If Len(nm) > 0 And nm <> "施工人" Then
                        If Not dd.exists(nm) Then
                            r = r + 1
                            dd(nm) = r
                            arr(r, 1) = nm
                        End If
                        rx = dd(nm)
                        For i = 2 To 10
                            If d.exists(arr(1, i)) Then
                                c = d(arr(1, i))
                                arr(rx, i) = Val(arr(rx, i)) + Val(brr(j, c))
                                arr(rx, 11) = Val(arr(rx, 11)) + Val(brr(j, c))
                            End If
                        Next i
                    End If
                Next j
            End If
        End If
    Next sh
    r = r + 1
    arr(r, 1) = "合计"
    For j = 2 To r - 1
        For i = 2 To UBound(arr, 2)
            arr(r, i) = arr(r, i) + arr(j, i)
        Next
    Next j
    arr(1, 1) = "姓名"
    Sheets("汇总").[a1].Resize(r, 11) = arr
    Application.ScreenUpdating = True
End Sub

liulang0808

附件内容供参考

jjmysjg

liulang0808 发表于 2024-8-17 07:31
附件内容供参考

谢谢版主，是这个效果。

ykcbf1100

花这么多精力去写代码，后期不容易维护的，还不如前期先规范好数据表。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.8.17
   
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.         c = .Cells(1, "XFD").End(1).Column
   
8.         zrr = .[a1].Resize(, c)
   
9.         For j = 2 To UBound(zrr, 2) - 1
   
10.             s = zrr(1, j)
    
11.             d1(s) = j
    
12.         Next
    
13.     End With
    
14.     ReDim brr(1 To 10000, 1 To c)
    
15.     For Each sht In Sheets
    
16.         If sht.Name <> sh.Name Then
    
17.             With sht
    
18.                 Set Rng = .UsedRange.Find("施工人")
    
19.                 bt = Rng.Row: col = Rng.Column
    
20.                 r = .Cells(Rows.Count, 1).End(3).Row
    
21.                 c = .Cells(bt, "XFD").End(1).Column
    
22.                 arr = .[a1].Resize(r, c)
    
23.             End With
    
24.             For i = bt + 1 To UBound(arr)
    
25.                 If Val(arr(i, 1)) Then
    
26.                     If InStr(arr(i, 1), "#") = 0 Then
    
27.                         s = arr(i, col)
    
28.                         If s <> Empty Then
    
29.                             If Not d.exists(s) Then
    
30.                                 m = m + 1
    
31.                                 d(s) = m
    
32.                                 brr(m, 1) = s
    
33.                                 For j = 1 To UBound(arr, 2)
    
34.                                     s1 = arr(bt, j)
    
35.                                     If d1.exists(s1) Then
    
36.                                         brr(m, d1(s1)) = arr(i, j)
    
37.                                     End If
    
38.                                 Next
    
39.                             Else
    
40.                                 r = d(s)
    
41.                                 For j = 1 To UBound(arr, 2)
    
42.                                     s1 = arr(bt, j)
    
43.                                     If d1.exists(s1) Then
    
44.                                         brr(r, d1(s1)) = brr(r, d1(s1)) + arr(i, j)
    
45.                                     End If
    
46.                                 Next
    
47.                             End If
    
48.                         End If
    
49.                     End If
    
50.                 End If
    
51.             Next
    
52.         End If
    
53.     Next
    
54.     With sh
    
55.         .UsedRange.Offset(1).Clear
    
56.         .[a2].Resize(m, 11) = brr
    
57.         For i = 2 To m + 1
    
58.             For j = 1 To 10
    
59.                 .Cells(i, 11) = Application.Sum(.Cells(i, 2).Resize(, 9))
    
60.             Next
    
61.         Next
    
62.         .Cells(m + 2, 1) = "项目合计"
    
63.         For j = 2 To 11
    
64.             .Cells(m + 2, j) = Application.Sum(.Cells(2, j).Resize(m))
    
65.         Next
    
66.         With .[a2].Resize(m + 1, 11)
    
67.             .Borders.LineStyle = 1
    
68.             .HorizontalAlignment = xlCenter
    
69.             .VerticalAlignment = xlCenter
    
70.         End With
    
71.     End With
    
72.     Set d = Nothing
    
73.     Set d1 = Nothing
    
74.     Application.ScreenUpdating = True
    
75.     MsgBox "OK！"
    
76. End Sub
    

复制代码

ynzsvt

一个表还包含不同表头的分表，太复杂了，都没考虑到。

jjmysjg

ykcbf1100 发表于 2024-8-17 19:39
花这么多精力去写代码，后期不容易维护的，还不如前期先规范好数据表。

谢谢大师的帮助！

jjmysjg

ynzsvt 发表于 2024-8-17 20:06
一个表还包含不同表头的分表，太复杂了，都没考虑到。

表格复制，老师的代码经典。

ynzsvt

jjmysjg 发表于 2024-8-17 20:15
表格复制，老师的代码经典。

没听明白你说的