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

紫寒100

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

我之前发的资料包含了所能涉及到的情况。

紫寒100

donghui2363 发表于 2021-4-23 14:31
嗯嗯，疏忽了.Range("a2").Resize(k, d.Count + 2) = brr 忘了加2了,年度还有合计用find查找也行

谢谢啦，真是麻烦你了。

紫寒100

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

Sub 全部合并()

老师，指定合并麻烦您再帮忙修改下，想达到输入什么提取什么，还是各工作簿列字段不一定完全相同，先前的代码合并后有空行、合计行、表尾，最后一列是错误码。辛苦您了。

donghui2363

紫寒100 发表于 2021-4-23 15:42
老师，指定合并麻烦您再帮忙修改下，想达到输入什么提取什么，还是各工作簿列字段不一定完全相同，先前的 ...

从哪输入？InputBox吗

紫寒100

donghui2363 发表于 2021-4-23 15:43
从哪输入？InputBox吗

就是在条件列输入什么就提取什么
从第三列C3开始输入

紫寒100

紫寒100 发表于 2021-4-23 16:00
就是在条件列输入什么就提取什么
从第三列C3开始输入

跟全提的其他要求一样，只是这次是办入什么就提什么

紫寒100

donghui2363 发表于 2021-4-23 15:43
从哪输入？InputBox吗

就是在条件行（第三行），黄色部分输入，上面回答的列输入错了。

donghui2363

改了一下，按照黄色单元格提取的
Sub 指定合并()
Dim wk As Workbook
Set d = CreateObject("scripting.dictionary")
    p = ThisWorkbook.Path & "\"
    sh = Dir(p & "*.xlsx")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
    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
    End With
    ReDim brr(1 To 10000, 1 To d.Count + 2)
    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
                    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
                    If d.exists(arr(r, j)) Then
                        brr(k, 1) = wk.Name
                        brr(k, 2) = wk.Sheets(1).Name
                        brr(k, d(arr(r, j)) + 2) = arr(I, j)
                    End If
                Next j
            Next I
            wk.Close
        End If
        sh = Dir
    Loop
    With Sheets("1-2指定列字段合并")
        .UsedRange.Offset(3, 0) = ""
        .Range("a3") = "工作簿"
        .Range("b3") = "工作表"
        .Range("a4").Resize(k, d.Count + 2) = brr
        .Cells.Columns.AutoFit
    End With
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

紫寒100

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

能不能把设计列为标准的那个改成以姓名列为标准，因为姓名列最标准，

紫寒100

donghui2363 发表于 2021-4-23 16:25
改了一下，按照黄色单元格提取的
Sub 指定合并()
Dim wk As Workbook

老师，不好意思，因为这几天感冒了，所以今天才来，谢谢您的帮助，还有一个小问题，就是合并后，两个分工作簿数据中间有空行，不想要空行，麻烦再帮忙修改一下，谢谢。