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

紫寒100

donghui2363 发表于 2021-4-21 15:50
指定合并按照你表格所列的列标题取查找的

如果指定提取我想更改列字段就不行了，可以修改代码吗？也就是我在列字段里输入什么提取什么。

紫寒100

donghui2363 发表于 2021-4-21 15:56
邪门啊，第一遍发的有\，第二遍用论坛的代码发的就没有\
arr = wkname(ThisWorkbook.Path & "\")

老师全部合并加了斜线后，合并不正确了，第3表没有数据，最后一表合计行也合并进来了。麻烦再帮我修改一下，谢谢。

donghui2363

刚看了一下，第三工作簿没有数据是我按照A列出现"年度"判断下一行为标题行的，第三表年度实在D列，所以没取到，另外你的工作簿为什么格式这么不一致

wrl168

紫寒100 发表于 2021-4-21 13:39
老师，我想把所有项目对应合并可以吗，比如电专业的"分配总量"，建设专业的“设总分配金额”和“建筑专业 ...

那你要把所有专业的表格至少发一个，这样才知道各种情况

紫寒100

wrl168 发表于 2021-4-22 11:52
那你要把所有专业的表格至少发一个，这样才知道各种情况

好，谢谢老师啦。

紫寒100

donghui2363 发表于 2021-4-22 10:26
刚看了一下，第三工作簿没有数据是我按照A列出现"年度"判断下一行为标题行的，第三表年度实在D列，所以没取 ...

实际工作中，就是不一致啊，要是一致就简单些了。

donghui2363

你试试

Sub 全部合并()
Dim wk As Workbook, brr(1 To 10000, 1 To 100)
Set d = CreateObject("scripting.dictionary")
    p = ThisWorkbook.Path & "\"
    sh = Dir(p & "*.xlsx")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
    Do While sh <> ""
        If sh <> ThisWorkbook.Name Then
            Set wk = Workbooks.Open(p & sh)
            arr = wk.Sheets(1).UsedRange
            For I = 1 To UBound(arr)
                For j = 1 To UBound(arr, 2)
                    If IsError(arr(I, j)) Then arr(I, j) = ""
                    If InStr(arr(I, j), "年度") Then
                        r = I + 1
                        For jj = 1 To UBound(arr, 2)
                            If arr(r, jj) = "" Then Exit For
                            If Not d.exists((arr(r, jj))) Then
                                d(arr(r, jj)) = d.Count + 1
                            End If
                        Next jj
                    ElseIf InStr(arr(I, j), "合计") Then
                        s = I - 1
                        Exit For
                    End If
                Next j
            Next I
            For I = r + 1 To s
                k = k + 1
                If arr(I, d("姓名")) = "" Then Exit For
                For j = 1 To UBound(arr, 2)
                    If arr(r, j) = "" Then Exit For
                    brr(k, 1) = wk.Name
                    brr(k, 2) = wk.Sheets(1).Name
                    brr(k, d(arr(r, j)) + 2) = arr(I, j)
                Next j
            Next I
            wk.Close
        End If
        sh = Dir
    Loop
    With Sheets("1-1全部列字段合并")
        .UsedRange.Offset(0, 0) = ""
        .Range("a1") = "工作簿"
        .Range("b1") = "工作表"
        .Range("c1").Resize(1, d.Count) = d.keys
        .Range("a2").Resize(k, d.Count) = brr
        .Cells.Columns.AutoFit
    End With
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

紫寒100

donghui2363 发表于 2021-4-22 16:14
你试试

Sub 全部合并()

谢谢啦 ，这个也挺好的。合并速度快。

紫寒100

donghui2363 发表于 2021-4-22 16:14
你试试

Sub 全部合并()

老师，全部合并这个想再咨询一下，比如电专业的分配总量，分配比例只有表头，没有数据

donghui2363

紫寒100 发表于 2021-4-23 14:16
老师，全部合并这个想再咨询一下，比如电专业的分配总量，分配比例只有表头，没有数据

嗯嗯，疏忽了.Range("a2").Resize(k, d.Count + 2) = brr 忘了加2了,年度还有合计用find查找也行