'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