20170706xlVBA汇总历时对阵数据

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

　　

转载于:https://www.cnblogs.com/nextseven/p/7124203.html