ExcelVBA汇总-多簿一表_to_一簿一表

    'yhd_2.汇总 -多簿一表_to_一簿一表
Sub yhd_ExcelVBA多簿一表_to_一簿一表()
    Dim title_Row As Integer, ShtNameStr As String, sht_i As Integer, used_Row As Integer, write_row As Integer
    Dim ThisWb As Workbook, OpenWb As Workbook, sht As Worksheet
    t = Timer
    disAppSet (False)
    ChDrive ThisWorkbook.Path
    ChDir ThisWorkbook.Path
    SelectFiles = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*", , "打开文件", , True)
    '    Debug.Print TypeName(SelectFiles)
    If TypeName(SelectFiles) = "Boolean" Then MsgBox "你选了“取消”,将退出": Exit Sub
    title_Row = Application.InputBox(prompt:="请输入标题行数：", Type:=1)
    '    Debug.Print TypeName(titleRowS)
    If StrPtr(titleRowS) = 0 Then MsgBox "你选了“取消”,将退出": Exit Sub
    ShtNameStr = Application.InputBox(prompt:="请输入工作表名称：", Type:=2)
    '     Debug.Print TypeName(ShtNameStr)
    If Len(ShtNameStr) = 0 Or StrPtr(ShtNameStr) = 0 Then MsgBox "你选了“取消”,将退出": Exit Sub
    Set ThisWb = ThisWorkbook
    With ThisWb
        If Wsh_Exists("汇总") Then Worksheets("汇总").Delete
        Set Thissht = .Worksheets.Add(After:=.Worksheets(.Worksheets.Count))
        Thissht.Name = "汇总"
    End With
    sht_i = 1
    For Each FileOne In SelectFiles
        Debug.Print FileOne
        '        ThisSht.Range("A" & i) = FileOne
        Set OpenWb = Workbooks.Open(FileOne)
        With OpenWb
            For Each sht In .Worksheets
                If InStr(sht.Name, ShtNameStr) Then
                    With sht
                        If sht_i = 1 Then
                            .Rows("1:" & title_Row).Copy Thissht.Range("A1")
                        End If
                        used_Row = .UsedRange.Rows.Count
                        write_row = Thissht.UsedRange.Rows.Count + 1
                        .Rows(title_Row + 1 & ":" & used_Row).Copy Thissht.Range("A" & write_row)
                    End With
                    sht_i = sht_i + 1
                End If
            Next
            .Close False
        End With
        Set OpenWb = Nothing
    Next
    MsgBox "合并" & sht_i & "个，用时：" & Format(Timer - t, "0.00秒")
    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
Public Function Wsh_Exists(ByVal sWshName As String) As Boolean
    Dim sName As String
    On Error GoTo ErrorHandler
    sName = ThisWorkbook.Sheets(sWshName).Name
    If Len(sName) > 0 Then Wsh_Exists = True
    Exit Function
ErrorHandler:
    Wsh_Exists = False
End Function