Public Sub GatherFilesData()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
Application.StatusBar = ">>>>>>>>程序正在运行>>>>>>>>" On Error GoTo ErrHandler Dim StartTime, UsedTime As Variant
StartTime = VBA.Timer
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
Dim FilePaths$()
Dim FileCount&, FileIndex&
Dim wb As Workbook
Dim Sht As Worksheet
Dim OpenWb As Workbook
Dim OpenSht As Worksheet
Dim EndRow As Long
Dim NextRow As Long Set wb = Application.ThisWorkbook
Set Sht = wb.Worksheets.Add(After:=wb.Worksheets(wb.Worksheets.Count)) With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = True
.InitialFileName = ThisWorkbook.Path
.Title = "请选择Excel工作簿"
.Filters.Clear
.Filters.Add "Excel工作簿", "*.xls*"
If .Show = -1 Then
FileCount = .SelectedItems.Count
ReDim FilePath(1 To FileCount)
For FileIndex = 1 To FileCount
FilePath(FileIndex) = .SelectedItems(FileIndex)
Debug.Print FilePath(FileIndex)
Next FileIndex
Else
MsgBox "您没有选中任何文件夹，本次汇总中断！"
Exit Sub
End If
End With For FileIndex = 1 To FileCount
If FileIndex = 1 Then
NextRow = 1
Else
With Sht
EndRow = .Cells.Find("*", .Cells(1, 1), xlValues, xlWhole, xlByRows, xlPrevious).Row
NextRow = EndRow + 1
End With
End If
Set OpenWb = Application.Workbooks.Open(FilePath(FileIndex))
Set OpenSht = OpenWb.Worksheets(1)
OpenSht.UsedRange.Copy Sht.Cells(NextRow, 1) OpenWb.Close False Next FileIndex UsedTime = VBA.Timer - StartTime
MsgBox "本次耗时：" & Format(UsedTime, "0.000秒"), vbOKOnly, "NextSeven QQ 84857038" ErrorExit:
Set wb = Nothing
Set Sht = Nothing
Set OpenWb = Nothing
Set OpenSht = Nothing Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
Application.StatusBar = False
Exit Sub ErrHandler:
If Err.Number <> 0 Then
MsgBox Err.Description & "！", vbCritical, "Excel Studio "
'Debug.Print Err.Description
Err.Clear
Resume ErrorExit
End If
End Sub