ExcelVBA汇总多工作簿中指定工作表到新工作簿

Sub yhd_ExcelVBA汇总多工作簿中指定工作表到新工作簿()
    Dim strPath As String, myshtName As String, fileName As String, Fso As Object
    Dim wb As Workbook, wbopen As Workbook, wsNew As Worksheet, sht As Worksheet
    Set Fso = CreateObject("Scripting.FileSystemObject")
    strPath = ThisWorkbook.Path
    ChDrive strPath
    ChDir strPath
    fileToOpen = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*", , "打开文件", , True)
    If TypeName(fileToOpen) = "Boolean" Then MsgBox "你选择了“取消”,将要退出程序": Exit Sub
    myshtName = Application.InputBox(prompt:="输入工作表名称", Title:="请输入", Default:="汇总", Type:=2)
    '定义变量
    disAppSet (False)
    '设置工作簿
    Set wb = ThisWorkbook
    '设置要复制的工作表
    For Each ff In fileToOpen
        '取文件名，用于工作表命名
        fileName = Fso.GetBaseName(ff)
        Set wbopen = Workbooks.Open(ff)
        With wbopen
            For Each sht In .Worksheets
                If InStr(sht.Name, myshtName) Then
                    sht.Copy after:=wb.Worksheets(wb.Worksheets.Count)
                    Set wsNew = wb.Worksheets(wb.Worksheets.Count)
                    wsNew.UsedRange.Value = wsNew.UsedRange.Value
                    wsNew.Name = fileName
                End If
            Next
            .Close False
        End With
    Next
    disAppSet (True)
End Sub
    '用法：disAppSet(true)开disAppSet(true)关
Sub disAppSet(flag As Boolean)
    With Application
        .ScreenUpdating = flag
        .DisplayAlerts = flag
        .AskToUpdateLinks = flag
        If flag Then
            .Calculation = xlCalculationAutomatic
        Else
            .Calculation = xlCalculationManual
        End If
    End With
End Sub