20171113xlVba指定文件夹多簿多表分表合并150

'2017年11月13日
'Next_Seven
'功能：文件夹对话框指定文件夹下，合并（复制粘贴）每个Excel文件内的指定子表内容，
'在名为"设置"的工作表A列 输入汇总子表的名称  在B列输入汇总子表的表头行数
'C列自动输出 有效汇总的sheet个数
Public Sub 指定文件夹多簿多表分表合并()
    AppSettings True
    Dim StartTime As Variant
    Dim UsedTime As Variant
    StartTime = VBA.Timer

    Dim FolderPath As String, FileName As String, FilePath As String
    Dim Arr As Variant, dSht As Object, Sht As Worksheet, Wb As Workbook
    Dim EndRow As Long, EndCol As Long, Ar As Variant
    Dim i As Long, j As Long, HeadRow As Long, NextRow As Long
    Dim Key As String, NewSht As Worksheet, Rng As Range
    Dim OpenWb As Workbook, OpenSht As Worksheet

    Set dSht = CreateObject("Scripting.Dictionary")
    Set Wb = Application.ThisWorkbook
    Set Sht = Wb.Worksheets("设置")
    With Sht
        Application.Intersect(.Range("C:C"), .UsedRange.Offset(1)).ClearContents
        EndRow = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
        If EndRow <= 1 Then
            MsgBox "未设置工作表名称!", vbInformation, "AuthorQQ 84857038"
            Exit Sub
        End If
        For i = 2 To EndRow
            If Len(.Cells(i, 2).Value) = 0 Then
                HeadRow = 1
            Else
                HeadRow = .Cells(i, 2).Value
            End If
            Key = Trim(.Cells(i, 1).Text)
            dSht(Key) = Array(Key, HeadRow, 0)
        Next i
    End With

    '获取文件夹路径
    FolderPath = GetFolderPath(ThisWorkbook.Path)
    If Len(FolderPath) = 0 Then
        MsgBox "您没有选中任何文件夹，本次汇总中断！"
        Exit Sub
    End If

    '获取文件名列表
    Arr = FsoGetFiles(FolderPath, "*.xls*", "*" & ThisWorkbook.Name & "*")
    For i = LBound(Arr) To UBound(Arr)
        FilePath = CStr(Arr(i))
        Debug.Print FilePath

        Set OpenWb = Application.Workbooks.Open(FilePath)
        For Each OpenSht In OpenWb.Worksheets
            Key = OpenSht.Name
            If dSht.Exists(Key) Then
                Ar = dSht(Key)
                HeadRow = Ar(1)
                If Ar(2) = 0 Then
                    '创建新工作表
                    Set NewSht = AddWorksheet(Wb, Key, True)
                    If Application.WorksheetFunction.CountA(OpenSht.Cells) > 0 Then
                        OpenSht.UsedRange.Copy NewSht.Range("A1")
                        Ar(2) = Ar(2) + 1
                    End If
                Else
                    Set NewSht = Wb.Worksheets(Key)
                    If Application.WorksheetFunction.CountA(OpenSht.Cells) > 0 Then
                        With NewSht
                            NextRow = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row + 1
                            OpenSht.UsedRange.Offset(HeadRow).Copy .Cells(NextRow, 1)
                        End With
                        Ar(2) = Ar(2) + 1
                    End If
                End If

                dSht(Key) = Ar

            End If
        Next OpenSht
        OpenWb.Close False

    Next i

    With Sht
        Set Rng = .Range("A2")
        Set Rng = Rng.Resize(dSht.Count, 3)
        Rng.Value = Application.Rept(dSht.Items, 1)
    End With

    Set dSht = Nothing
    Set Sht = Nothing
    Set NewSht = Nothing
    Set OpenWb = Nothing
    Set OpenSht = Nothing
    Set Rng = Nothing

    UsedTime = VBA.Timer - StartTime
    Debug.Print "UsedTime ：" & Format(UsedTime, "#0.0000 Seconds")
    'MsgBox "UsedTime ：" & Format(UsedTime, "#0.0000 Seconds")
    AppSettings False

End Sub

Private Function GetFolderPath(InitialPath) As String
    Dim FolderPath As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = InitialPath
        .AllowMultiSelect = False
        .Title = "请选取Excel工作簿所在文件夹"
        If .Show = -1 Then
            FolderPath = .SelectedItems(1)
        Else
            GetFolderPath = ""
            'MsgBox "您没有选中任何文件夹，本次汇总中断！"
            Exit Function
        End If
    End With

    If Right(FolderPath, 1) <> Application.PathSeparator Then FolderPath = FolderPath & Application.PathSeparator
    GetFolderPath = FolderPath
End Function
Private Function FsoGetFiles(ByVal FolderPath As String, ByVal Pattern As String, Optional ComplementPattern As String = "") As String()
    Dim Arr() As String
    Dim FSO As Object
    Dim ThisFolder As Object
    Dim OneFile As Object
    ReDim Arr(1 To 1)
    Arr(1) = "None"
    Dim Index As Long
    Index = 0
    Set FSO = CreateObject("Scripting.FileSystemObject")
    On Error GoTo ErrorExit
    Set ThisFolder = FSO.getfolder(FolderPath)
    If Err.Number <> 0 Then Exit Function
    For Each OneFile In ThisFolder.Files
        If OneFile.Name Like Pattern Then
            If Len(ComplementPattern) > 0 Then
                If Not OneFile.Name Like ComplementPattern Then
                    Index = Index + 1
                    ReDim Preserve Arr(1 To Index)
                    Arr(Index) = OneFile.Path
                End If
            Else
                Index = Index + 1
                ReDim Preserve Arr(1 To Index)
                Arr(Index) = OneFile.Path
            End If
        End If
    Next OneFile
ErrorExit:
    FsoGetFiles = Arr
    Erase Arr
    Set FSO = Nothing
    Set ThisFolder = Nothing
    Set OneFile = Nothing
End Function
Private Function AddWorksheet(ByVal Wb As Workbook, ByVal ShtName As String, Optional ReplaceSymbol As Boolean = True) As Worksheet
    Dim Sht As Worksheet
    If Len(ShtName) = 0 Or Len(ShtName) > 31 Then
        Set AddWorksheet = Nothing
        MsgBox "Worksheet名称长度不符！", vbInformation, "AddWorksheet"
        Exit Function
    Else
        On Error Resume Next
        Set Sht = Wb.Worksheets(ShtName)
        If Err.Number = 9 Then
            Set Sht = Wb.Worksheets.Add(After:=Wb.Worksheets(Wb.Worksheets.Count))
            Err.Clear
            On Error GoTo 0
            On Error Resume Next
            Sht.Name = ShtName
            If Err.Number = 1004 Then
                Err.Clear
                On Error GoTo 0
                If ReplaceSymbol Then
                    Arr = Array("/", "\", "?", "*", "[", "]")
                    For i = LBound(Arr) To UBound(Arr)
                        ShtName = Replace(ShtName, Arr(i), "")
                    Next i
                    Set AddWorksheet = AddWorksheet(Wb, ShtName)    '再次调用
                Else
                    Set AddWorksheet = Nothing
                    MsgBox "Worksheet名称含有特殊符号！", vbInformation, "AddWorksheet"
                End If
            Else
                Set AddWorksheet = Sht
            End If
        ElseIf Err.Number = 0 Then
            Set AddWorksheet = Sht
        End If
    End If
End Function
Public Sub AppSettings(Optional IsStart As Boolean = True)
    Application.ScreenUpdating = IIf(IsStart, False, True)
    Application.DisplayAlerts = IIf(IsStart, False, True)
    Application.Calculation = IIf(IsStart, xlCalculationManual, xlCalculationAutomatic)
    Application.StatusBar = IIf(IsStart, ">>>>>>>>Macro Is Running>>>>>>>>", False)
End Sub