表内有多行位置不同的标题，能否按标题合并列数据

jjmysjg

工作簿内有多张工作表(本附件只列举3张),表内的标题行有多行，且标题位置不定。

能否按汇总表的标题名将分表的多行标题对应汇总到汇总表，按标题名对齐列数据。
谢谢各位！

gwjkkkkk

表式不够合理，每个工作表数据有分表，取数比较难。。。

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.8.19
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Set sh = ThisWorkbook.Sheets("汇总")
   
5.     With sh
   
6.         c = .Cells(1, "XFD").End(1).Column
   
7.         zrr = .[a1].Resize(, c)
   
8.         For j = 1 To UBound(zrr, 2) - 1
   
9.             s = zrr(1, j)
   
10.             d(s) = j
    
11.         Next
    
12.     End With
    
13.     ReDim brr(1 To 10000, 1 To c)
    
14.     For Each sht In Sheets
    
15.         If sht.Name <> sh.Name Then
    
16.             With sht
    
17.                 Set Rng = .UsedRange.Find("施工人")
    
18.                 bt = Rng.Row: col = Rng.Column
    
19.                 r = .Cells(Rows.Count, 1).End(3).Row
    
20.                 c = .Cells(bt, "XFD").End(1).Column
    
21.                 arr = .[a1].Resize(r, c)
    
22.                 fn = .Name
    
23.             End With
    
24.             For i = bt + 1 To UBound(arr)
    
25.                 If Val(arr(i, 7)) Then
    
26.                     m = m + 1
    
27.                     For j = 1 To UBound(arr, 2)
    
28.                         s = arr(bt, j)
    
29.                         If d.exists(s) Then
    
30.                             brr(m, d(s)) = arr(i, j)
    
31.                         End If
    
32.                     Next
    
33.                     brr(m, UBound(zrr, 2)) = fn
    
34.                 End If
    
35.             Next
    
36.         End If
    
37.     Next
    
38.     With sh
    
39.         .[a2:k10000].ClearContents
    
40.         With .[a2].Resize(m, 11)
    
41.             .Value = brr
    
42.             .Borders.LineStyle = 1
    
43.             .HorizontalAlignment = xlCenter
    
44.             .VerticalAlignment = xlCenter
    
45.         End With
    
46.     End With
    
47.     Set d = Nothing
    
48.     Application.ScreenUpdating = True
    
49.     MsgBox "OK！"
    
50. End Sub
    
51. 
    

复制代码

jjmysjg

gwjkkkkk 发表于 2024-8-19 20:56
表式不够合理，每个工作表数据有分表，取数比较难。。。

能否以施工人为关键字，定位各表的标题行。

ykcbf1100

修正一个错误

1. Sub ykcbf()   '//2024.8.19
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Set sh = ThisWorkbook.Sheets("汇总")
   
5.     With sh
   
6.         c = .Cells(1, "XFD").End(1).Column
   
7.         zrr = .[a1].Resize(, c)
   
8.         For j = 1 To UBound(zrr, 2) - 1
   
9.             s = zrr(1, j)
   
10.             d(s) = j
    
11.         Next
    
12.     End With
    
13.     ReDim brr(1 To 10000, 1 To c)
    
14.     For Each sht In Sheets
    
15.         If sht.Name <> sh.Name Then
    
16.             With sht
    
17.                 Set Rng = .UsedRange.Find("施工人")
    
18.                 bt = Rng.Row: col = Rng.Column
    
19.                 r = .Cells(Rows.Count, 1).End(3).Row
    
20.                 c = .Cells(bt, "XFD").End(1).Column
    
21.                 c1 = .UsedRange.Find("方量").Column
    
22.                 arr = .[a1].Resize(r, c)
    
23.                 fn = .Name
    
24.             End With
    
25.             For i = bt + 1 To UBound(arr)
    
26.                 If Val(arr(i, c1)) Then
    
27.                     m = m + 1
    
28.                     For j = 1 To UBound(arr, 2)
    
29.                         s = arr(bt, j)
    
30.                         If d.exists(s) Then
    
31.                             brr(m, d(s)) = arr(i, j)
    
32.                         End If
    
33.                     Next
    
34.                     brr(m, UBound(zrr, 2)) = fn
    
35.                 End If
    
36.             Next
    
37.         End If
    
38.     Next
    
39.     With sh
    
40.         .[a2:k10000].ClearContents
    
41.         With .[a2].Resize(m, 11)
    
42.             .Value = brr
    
43.             .Borders.LineStyle = 1
    
44.             .HorizontalAlignment = xlCenter
    
45.             .VerticalAlignment = xlCenter
    
46.         End With
    
47.     End With
    
48.     Set d = Nothing
    
49.     Application.ScreenUpdating = True
    
50.     MsgBox "OK！"
    
51. End Sub
    
52. 
    

复制代码

醉眼看尘世

前两天不是有此贴求助，何以重发？

ykcbf1100

醉眼看尘世 发表于 2024-8-19 21:15
前两天不是有此贴求助，何以重发？

不一样，这个帖子是合并，前一个帖子是汇总。

jjmysjg

醉眼看尘世 发表于 2024-8-19 21:15
前两天不是有此贴求助，何以重发？

那个贴子因为这个原因，完成了一半。

ykcbf1100

jjmysjg 发表于 2024-8-19 21:17
那个贴子因为这个原因，完成了一半。

上个帖子我的回复应该解决问题吧，标题的问题，上次我就考虑到了。我这次的代码一半来自于上一次回复。