查找关键字所在列，复制所需行内容

S110018

非常感谢8楼、9楼两位老师不惜赐教！8楼老师的关键字查找设在固定行，能否修改不固定行或列呢，就像我附表说的那样。
9 楼老师我运行代码，在
sht.Range(Cells(r + 1, c), Cells(er1, c)).Copy .Range("B" & er + 1)
提示：应用程序定义或对象定义错误，为何呢？

liulang0808

Sub 按钮1_Click()
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = ThisWorkbook.Path & "\"
        .Title = "请选择需汇总文件所在文件夹"
        If .Show Then pth = .SelectedItems(1) Else Exit Sub '
    End With
    Set d = CreateObject("scripting.dictionary")
    Set fso = CreateObject("scripting.filesystemobject")
    Set sh = ActiveSheet
    arr = sh.[a1].Resize(9999, sh.UsedRange.Columns.Count)
    For i = 2 To UBound(arr, 2)
        d(arr(2, i)) = i
    Next i
    r = 2
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    sh.UsedRange.Offset(2).ClearContents
    For Each f In fso.getfolder(pth).Files
        With Workbooks.Open(f)
            brr = .Sheets(1).UsedRange
            .Close False
        End With
        For j = 3 To UBound(brr) - 1
            r = r + 1
            arr(r, 1) = r - 2
            For i = 2 To UBound(brr, 2)
                If d.exists(brr(2, i)) Then
                    arr(r, d(brr(2, i))) = brr(j, i)
                End If
            Next i
        Next
    Next f
    sh.[a1].Resize(r, UBound(arr, 2)) = arr
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

liulang0808

选中需要汇总文件所在文件夹，汇总即可，如果有出入可以微调

S110018

liulang0808 发表于 2023-5-3 13:43
选中需要汇总文件所在文件夹，汇总即可，如果有出入可以微调

谢谢老师！