求助：多表头有合计行表尾的多工作簿合并

紫寒100

多工作簿合并：说明：

1、待合并的各工作簿有多行表头，有合计行、表尾，有的表中间还有设置了公式但没有数据的行或者空白行。
2、待合并的各工作簿行数不相同。
3、待合并的各工作簿表头行数是一致的。
4、待合并的各工作簿列字段乱序，也不完全一致。

需求：
1、各工作簿所有列字段自动添加并全部对应合并，在合并表左侧添加工作簿名、工作表名列，不保留其他表头、空白行、合计行、表尾及有公式没数据的行
2、各工作簿指定列字段对应合并，在合并表左侧添加工作簿名、工作表名列，不保留表头、空白行、合计行、表尾及有公式没数据的行

待合并的工作簿多，数据量大。

谢谢论坛里各位老师们的帮助。

无敌小猪猪

先用着再说

wrl168

你其中有个《比例》的字段，源文件里是没有，你也没有进行定义

紫寒100

wrl168 发表于 2021-4-20 10:36
你其中有个《比例》的字段，源文件里是没有，你也没有进行定义

好，我去看看，谢谢老师。

紫寒100

wrl168 发表于 2021-4-20 10:36
你其中有个《比例》的字段，源文件里是没有，你也没有进行定义

老师您好。有的工作表有“比例”列字段，有的没有，也就是说列字段不完全相同。

紫寒100

无敌小猪猪 发表于 2021-4-20 10:30
先用着再说

老师您好：我的意思是把各待合并的工作簿里的数据，按照列字段对应合并，不保留表头、空行、合计行和表尾，只保留前面要提取的列字段和中间的数据。

wrl168

一键选择数据源文件，完成加载看一下是不是你要的效果

donghui2363

你测试一下
Sub 指定合并()
Dim wk As Workbook, sht As Worksheet, dcnt As Integer
Dim brr(), d As Object, dic As Object
Set d = CreateObject("scripting.dictionary")
    arr = wkname(ThisWorkbook.Path & "\")
    ReDim brr(1 To UBound(arr))
    For i = 1 To UBound(arr)
        Set wk = Workbooks.Open(arr(i, 2))
        Set sht = wk.Sheets(1)
        brr(i) = sht.UsedRange
        brr(i)(1, 1) = wk.Name
        brr(i)(1, 2) = sht.Name
        wk.Close
    Next i
    With Sheets("1-2指定列字段合并")
        For j = 3 To 100
            If .Cells(3, j) = "" Then Exit For
            n = n + 1
            d(.Cells(3, j).Value) = n
        Next j
        ReDim crr(1 To UBound(brr))
        For r = 1 To UBound(brr)
            For i = 1 To UBound(brr(r))
                If InStr(brr(r)(i, 1), "年度") Then
                    For j = 1 To UBound(brr(r), 2)
                        If Trim(brr(r)(i + 1, j)) = vbNullString Then Exit For
                        If d.exists(brr(r)(i + 1, j)) Then
                            crr(r) = bi(d, brr(r), i + 1, d.Count + 2)
                            Exit For
                        End If
                    Next j
                End If
            Next i
        Next r
        ReDim frr(1 To 10000, 1 To d.Count + 2)
        For r = 1 To UBound(crr)
            For i = 1 To UBound(crr(r))
                If crr(r)(i, 6) = "" Then Exit For
                k = k + 1
                For j = 1 To UBound(crr(r), 2)
                    frr(k, j) = crr(r)(i, j)
                Next j
            Next i
        Next r
        .Range("a4").Resize(k, j) = frr
    End With
End Sub
Function wkname(mpath As String) As Variant
Dim arr()
    sh = Dir(mpath & "*.xlsx")
    k = 1
    Do While sh <> ""
        If sh <> ThisWorkbook.Name Then
        ReDim Preserve arr(1 To 2, 1 To k)
            arr(1, k) = k
            arr(2, k) = mpath & sh
            k = k + 1
        End If
        sh = Dir
    Loop
    wkname = Application.Transpose(arr)
End Function
Function bi(dic As Object, mbrr As Variant, qs As Integer, dcnt As Integer) As Variant
ReDim err(1 To 10000, 1 To dcnt)
    For i = qs + 1 To UBound(mbrr)
        If mbrr(qs, 1) = "" Then Exit For
        k = k + 1
        For j = 1 To UBound(mbrr, 2)
            If mbrr(qs, j) = "" Then Exit For
            If dic.exists(mbrr(qs, j)) Then
                err(k, 1) = mbrr(1, 1)
                err(k, 2) = mbrr(1, 2)
                err(k, dic(mbrr(qs, j)) + 2) = mbrr(i, j)
            End If
        Next j
    Next i
    bi = err
End Function

紫寒100

wrl168 发表于 2021-4-20 12:39
一键选择数据源文件，完成加载看一下是不是你要的效果

感谢帮助，还有一个问题，如果设计号为空时，提取的数据不正确。麻烦老师帮忙修改一下，谢谢啦。第7表设计号为空。

donghui2363

看看对不对

1. Sub 指定合并()
   
2. Dim wk As Workbook, sht As Worksheet, dcnt As Integer
   
3. Dim brr(), d As Object, dic As Object
   
4. Set d = CreateObject("scripting.dictionary")
   
5.     arr = wkname(ThisWorkbook.Path & "")
   
6.     ReDim brr(1 To UBound(arr))
   
7.     For i = 1 To UBound(arr)
   
8.         Set wk = Workbooks.Open(arr(i, 2))
   
9.         Set sht = wk.Sheets(1)
   
10.         brr(i) = sht.UsedRange
    
11.         brr(i)(1, 1) = wk.Name
    
12.         brr(i)(1, 2) = sht.Name
    
13.         wk.Close
    
14.     Next i
    
15.     With Sheets("1-2指定列字段合并")
    
16.         For j = 3 To 100
    
17.             If .Cells(3, j) = "" Then Exit For
    
18.             n = n + 1
    
19.             d(.Cells(3, j).Value) = n
    
20.         Next j
    
21.         ReDim crr(1 To UBound(brr))
    
22.         For r = 1 To UBound(brr)
    
23.             For i = 1 To UBound(brr(r))
    
24.                 If InStr(brr(r)(i, 1), "年度") Then
    
25.                     For j = 1 To UBound(brr(r), 2)
    
26.                         If Trim(brr(r)(i + 1, j)) = vbNullString Then Exit For
    
27.                         If d.exists(brr(r)(i + 1, j)) Then
    
28.                             crr(r) = bi(d, brr(r), i + 1, d.Count + 2)
    
29.                             Exit For
    
30.                         End If
    
31.                     Next j
    
32.                 End If
    
33.             Next i
    
34.         Next r
    
35.         ReDim frr(1 To 10000, 1 To d.Count + 2)
    
36.         For r = 1 To UBound(crr)
    
37.             For i = 1 To UBound(crr(r))
    
38.                 If crr(r)(i, 6) = "" Then Exit For
    
39.                 k = k + 1
    
40.                 For j = 1 To UBound(crr(r), 2)
    
41.                     frr(k, j) = crr(r)(i, j)
    
42.                 Next j
    
43.             Next i
    
44.         Next r
    
45.         .Range("a4").Resize(k, j) = frr
    
46.     End With
    
47. End Sub
    
48. Sub 全部合并()
    
49. Dim wk As Workbook, sht As Worksheet, dcnt As Integer
    
50. Dim brr(), d As Object, dic As Object
    
51. Set d = CreateObject("scripting.dictionary")
    
52.     arr = wkname(ThisWorkbook.Path & "")
    
53.     ReDim brr(1 To UBound(arr))
    
54.     For i = 1 To UBound(arr)
    
55.         Set wk = Workbooks.Open(arr(i, 2))
    
56.         Set sht = wk.Sheets(1)
    
57.         brr(i) = sht.UsedRange
    
58.         brr(i)(1, 1) = wk.Name
    
59.         brr(i)(1, 2) = sht.Name
    
60.         wk.Close
    
61.     Next i
    
62.     n = 2
    
63.     For r = 1 To UBound(brr)
    
64.         For i = 1 To UBound(brr(r))
    
65.         If InStr(brr(r)(i, 1), "年度") Then
    
66.             brr(r)(1, 3) = i + 1
    
67.             For j = 1 To UBound(brr(r), 2)
    
68.                 If Trim(brr(r)(i + 1, j)) = vbNullString Then
    
69.                     brr(r)(1, 4) = j - 1
    
70.                     Exit For
    
71.                 End If
    
72.                 If Not d.exists(brr(r)(i + 1, j)) Then
    
73.                     n = n + 1
    
74.                     d(brr(r)(i + 1, j)) = n
    
75.                 End If
    
76.             Next j
    
77.         End If
    
78.         Next i
    
79.     Next r
    
80.     ReDim crr(1 To 10000, 1 To d.Count + 2)
    
81.     For r = 1 To UBound(brr)
    
82.         For i = brr(r)(1, 3) + 1 To UBound(brr(r))
    
83.             If brr(r)(i, 6) = "" Then Exit For
    
84.             k = k + 1
    
85.             crr(k, 1) = brr(r)(1, 1)
    
86.             crr(k, 2) = brr(r)(1, 2)
    
87.             For j = 1 To brr(r)(1, 4)
    
88.                 If d.exists(brr(r)(brr(r)(1, 3), j)) Then
    
89.                     s = d(brr(r)(brr(r)(1, 3), j))
    
90.                     crr(k, s) = brr(r)(i, j)
    
91.                 End If
    
92.             Next j
    
93.         Next i
    
94.     Next r
    
95.     With Sheets("1-1全部列字段合并")
    
96.         .UsedRange = ""
    
97.         .Range("a1") = "工作簿名"
    
98.         .Range("b1") = "工作表名"
    
99.         .Range("c1").Resize(1, d.Count) = d.keys
    
100.         .Range("a2").Resize(k, d.Count) = crr
     
101.         .Cells.Columns.AutoFit
     
102.     End With
     
103. End Sub
     
104. Function wkname(mpath As String) As Variant
     
105. Dim arr()
     
106.     sh = Dir(mpath & "*.xlsx")
     
107.     k = 1
     
108.     Do While sh <> ""
     
109.         If sh <> ThisWorkbook.Name Then
     
110.         ReDim Preserve arr(1 To 2, 1 To k)
     
111.             arr(1, k) = k
     
112.             arr(2, k) = mpath & sh
     
113.             k = k + 1
     
114.         End If
     
115.         sh = Dir
     
116.     Loop
     
117.     wkname = Application.Transpose(arr)
     
118. End Function
     
119. Function bi(dic As Object, mbrr As Variant, qs As Integer, dcnt As Integer) As Variant
     
120. ReDim err(1 To 10000, 1 To dcnt)
     
121.     For i = qs + 1 To UBound(mbrr)
     
122.         If mbrr(qs, 1) = "" Then Exit For
     
123.         k = k + 1
     
124.         For j = 1 To UBound(mbrr, 2)
     
125.             If mbrr(qs, j) = "" Then Exit For
     
126.             If dic.exists(mbrr(qs, j)) Then
     
127.                 err(k, 1) = mbrr(1, 1)
     
128.                 err(k, 2) = mbrr(1, 2)
     
129.                 err(k, dic(mbrr(qs, j)) + 2) = mbrr(i, j)
     
130.             End If
     
131.         Next j
     
132.     Next i
     
133.     bi = err
     
134. End Function

复制代码