Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) Public Sub GatherDataPicker() Application.ScreenUpdating = False Application.DisplayAlerts = False Application.Calculation = xlCalculationManual Application.StatusBar = ">>>>>>>>程序正在运行>>>>>>>>" 'On Error GoTo ErrHandler Dim StartTime, UsedTime As Variant StartTime = VBA.Timer '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> Dim wb As Workbook Dim Sht As Worksheet Dim EndRow As Long Dim OpenWb As Workbook Dim OpenSht As Worksheet Const SHEET_INDEX = "DB-B01" '"DB-C01" '引号内修改的是Sheet Name 表名(有人也叫页名) Const TITLE_ROW As Long = 2 '这里修改的是标题所占的行数 Dim FolderPath As String Dim FileName As String Dim FileCount As Long '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> With Application.FileDialog(msoFileDialogFolderPicker) .InitialFileName = ThisWorkbook.Path .AllowMultiSelect = False .Title = "请选取Excel工作簿所在文件夹" If .Show = -1 Then FolderPath = .SelectedItems(1) Else MsgBox "您没有选中任何文件夹,本次汇总中断!" Exit Sub End If End With If Right(FolderPath, 1) <> "" Then FolderPath = FolderPath & "" '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> Set wb = Application.ThisWorkbook '工作簿级别 Set Sht = wb.Worksheets(1) Sht.Cells.Clear 'FolderPath = ThisWorkbook.Path & "" FileCount = 0 FileName = Dir(FolderPath & "*.xls*") Do While FileName <> "" If FileName <> ThisWorkbook.Name Then FileCount = FileCount + 1 Set OpenWb = Application.Workbooks.Open(FolderPath & FileName) 'Sleep 5000 'SendKeys "~" With OpenWb Set OpenSht = .Worksheets(SHEET_INDEX) With OpenSht EndRow = .Cells.Find("*", .Cells(1, 1), xlValues, xlWhole, xlByRows, xlPrevious).Row If FileCount = 1 Then Set Rng = .Range("A1:ADT" & EndRow) Rng.Copy Sht.Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False Else Set Rng = .Range("A" & TITLE_ROW + 1 & ":ADT" & EndRow) EndRow = Sht.Cells.Find("*", Sht.Cells(1, 1), xlValues, xlWhole, xlByRows, xlPrevious).Row Rng.Copy Sht.Cells(EndRow + 1, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False End If End With .Close False End With End If FileName = Dir Loop '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> UsedTime = VBA.Timer - StartTime MsgBox "本次耗时:" & Format(UsedTime, "0.000秒"), vbOKOnly, " Excel Studio QQ84857038" ErrorExit: Set wb = Nothing Set Sht = Nothing Set OpenWb = Nothing Set OpenSht = Nothing Set Rng = Nothing Application.ScreenUpdating = True Application.DisplayAlerts = True Application.Calculation = xlCalculationAutomatic Application.StatusBar = False Exit Sub '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> ErrHandler: If Err.Number <> 0 Then MsgBox Err.Description & "!" & FileName, vbCritical, " Excel Studio QQ84857038" Err.Clear Resume ErrorExit End If End Sub