一个工作簿内所有工作表指定区域合并至新表，跪求大神帮忙

纯黑奥利奥

需求目标成果展示：


需求目标：
在新表中显示，一个工作簿里每一个工作表的B6单元格及A9至E列的最后一个非空单元格（黄色标注部分）。
每个工作表基本不超过30行，为保险起见，能否在完成时提示是否有超过30行的工作表，如果有，哪一个工作表的行数超过30行。
能力有限，不知道哪里有问题，望大神予以解答。谢谢！

纯黑奥利奥

第一次发帖，格式没弄好，见谅...

纯黑奥利奥

大哥们...谁来救救我吧....

纯黑奥利奥

大神们，这是我照着修改的，不知道哪里出问题了，帮忙看下吧。

Sub Copy_Source01()
    Application.ScreenUpdating = False
    Dim stMedd As String, tFilename As String, myName As String
    Dim MaxR As Long
    Dim arr
    Dim sss As Single
    Dim sht As Worksheet
    sss = Timer
    Select Case MsgBox("【是】：全部清空重新添加数据" & Chr(10) & _
        "【否】：表示原有基础新增记录" & Chr(10) & _
        "【取消】：表示退出操作", vbExclamation + vbYesNoCancel + vbDefaultButton3, "提示")
Case vbYes
    Range("A2:E65536").ClearContents
Case vbNo
Case Else
    Exit Sub
End Select
stMedd = "请选择文件目录："
Set obMapp = CreateObject("Shell.Application").BrowseForFolder(0, stMedd, &H1)
If Not obMapp Is Nothing Then
    Directory = obMapp.self.Path & "\"
Else
    Exit Sub
End If
Set fso = CreateObject("scripting.filesystemobject")
Set ff = fso.getfolder(Directory)
With ThisWorkbook.Sheets("汇总")
    For Each f In wb.workbooksheets
        If f.Name <> ThisWorkbook.Name Then
            Set wb = Workbooks.Open(f, 0, 1)
            n = n + 1
            MaxR = wb.Sheets("sheet1").Range("a65536").End(3).Row
            wb.Sheets("sheet1").Range(B6).Copy
            ThisWorkbook.Sheets("汇总").Range("A" & .[B65536].End(3).Row + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
            wb.Sheets("sheet1").Range("a5:Q" & MaxR).Copy
            ThisWorkbook.Sheets("汇总").Range("B" & .[B65536].End(3).Row + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
        End If
        wb.Close False
    Next f
End With
arr = Array("代码", "物料代码", "物料名称", "规格型号", "单位", "数量")
ThisWorkbook.Sheets("汇总").[A1].Resize(1, 6) = arr
MsgBox "数据【复制】完毕:耗时" & Format(Timer - sss, "0.000") & " 秒!!" & Chr(10) & "共计" & n & "个文件", 64, "提示信息"
Application.ScreenUpdating = True
End Sub

网海遨游

楼主：这样行不？请测试

Sub test1()
    Application.ScreenUpdating = False: Application.DisplayAlerts = False: Application.EnableEvents = False
    Set sh1 = ThisWorkbook.Sheets("汇总")
    sh1.Columns("a:z").Clear
    mp = ThisWorkbook.Path & "\"
    mf = "数据源.xls"
    Set dk = Workbooks.Open(mp & mf)
    For Each sht In dk.Sheets
        n = n + 1
        r = sht.[a65536].End(3).Row
        r1 = r - 8
        If n = 1 Then
            sht.[b8:e8].Copy sh1.[c1]
            sh1.[a1] = sht.[b5]
            sh1.[b1] = "物料" & sht.[a8]
        End If
        r2 = sh1.[a65536].End(3).Row + 1
        sh1.Cells(r2, 1).Resize(r1, 1) = sht.[b6]
        sht.Range("a9:e" & r).Copy: sh1.Cells(r2, 2).PasteSpecial Paste:=xlPasteValues
        If r1 > 30 Then MsgBox "数据源中“" & sht & "”数据超过30行！", 48, "温馨提示："
    Next sht
            dk.Close
    ThisWorkbook.Save
    Application.ScreenUpdating = True: Application.DisplayAlerts = True: Application.EnableEvents = True
End Sub

纯黑奥利奥

网海遨游 发表于 2019-6-12 10:57
楼主：这样行不？请测试

Sub test1()

谢谢，可以的！但是总的数据源最少有4000多个工作表，数据多了就提示错误了。

网海遨游

纯黑奥利奥 发表于 2019-6-12 11:16
谢谢，可以的！但是总的数据源最少有4000多个工作表，数据多了就提示错误了。

数据源是4000多个工作薄？还是工作表？因为你提供数据源只一个“数据源.xls”

纯黑奥利奥

111111111111111111111111

纯黑奥利奥

网海遨游 发表于 2019-6-12 14:51
数据源是4000多个工作薄？还是工作表？因为你提供数据源只一个“数据源.xls”

附件数据源是截取的示例，实际是一个工作簿中有4000多个工作表

网海遨游

我的理解可能不到位。一个工作薄中，能装下4000多个工作表？
工作薄与工作表是有区别的。你能否多提供几个数据源，当然不必要4000了，5到10个就行了。