20161227xlVBA多文件合并计算

Sub NextSeven_CodeFrame()

'应用程序设置

    Application.ScreenUpdating = False

    Application.DisplayAlerts = False

    Application.Calculation = xlCalculationManual

    '错误处理

    On Error GoTo ErrHandler

    '计时器

    Dim StartTime, UsedTime

    StartTime = VBA.Timer

    Dim msg

    msg = MsgBox("本次执行将会预先清除合并计算的区域，重要文件请做好备份,并且请您确认当前表就是您要汇总的总表！是否继续执行？按是继续执行！按否退出执行!", vbYesNo, "NS Excel工作室")

    If msg = vbNo Then Exit Sub

    Dim ShtName

    Dim ShtIndex

    Dim RngAddress

    msg = MsgBox("是否指定分表的名称？按是则输入分表名称，按否则输入分表的序号！", vbYesNo, "NS Excel工作室")

    If msg = vbYes Then

        ShtName = Application.InputBox("请输入分表名称：", "NS Excel工作室", , , , , , 2)

    Else

        ShtIndex = Application.InputBox("请输入分表序号：", "NS Excel工作室", , , , , , 1)

    End If

    RngAddress = "B6:AU12"

    t = VBA.Timer

    Dim FileCount&

    Dim wb As Workbook, OpenWb As Workbook

    Dim sht As Worksheet, OneSht As Worksheet

    Dim Rng As Range, OneRng As Range

    Dim arr() As Double, NewArr As Variant

    Dim FolderPath$, FileName$

    Dim oneCell As Range

    Set wb = Application.ThisWorkbook

    Set sht = wb.ActiveSheet

    Set Rng = sht.Range(RngAddress)

    Rng.Cells.ClearContents

    RowCount = Rng.Rows.Count

    columnCount = Rng.Columns.Count

    FolderPath = wb.Path & "\子文件夹\"

    FileCount = 0

    FileName = Dir(FolderPath & "*.xls*")

    Do While FileName <> ""

        FileCount = FileCount + 1

        Set OpenWb = Application.Workbooks.Open(FolderPath & FileName)

        If ShtName <> "" Then

            Set OneSht = OpenWb.Worksheets(ShtName)

        Else

            Set OneSht = OpenWb.Worksheets(CLng(ShtIndex))

        End If

        Debug.Print OneSht.Name

        Set OneRng = OneSht.Range(RngAddress)

        For Each oneCell In OneRng.Cells

                If Len(oneCell.Value) > 0 Then

                    If IsNumeric(oneCell.Value) = False Then

                        MsgBox "文件名：" & FileName & "  单元格： " & oneCell.Address & "  的内容不是数字，不能相加，请规范后再次执行求和！" & "——NextSeven竭诚为您服务。" & vbCrLf & "更多服务需求请咨询：QQ84857038 淘宝店号9157940 店铺OfficeVBA自动化", vbOKOnly + vbCritical, "NextSeven提示您"

                        Exit Sub

                    End If

                End If

        Next oneCell

        OneRng.Copy

        Rng.Cells(1, 1).PasteSpecial xlPasteValues, xlAdd, True, False

        OpenWb.Close False

        FileName = Dir

    Loop

    '运行耗时

    UsedTime = VBA.Timer - StartTime

    MsgBox "本次运行耗时：" & Format(UsedTime, "0.0000000秒")

ErrorExit:        '错误处理结束，开始环境清理

    Set wb = Nothing

    Set sht = Nothing

    Set Rng = Nothing

    Application.ScreenUpdating = True

    Application.DisplayAlerts = True

    Application.Calculation = xlCalculationAutomatic

    Exit Sub

ErrHandler:

    If Err.Number <> 0 Then

        MsgBox Err.Description & "！", vbCritical, "错误提示！"

        'Debug.Print Err.Description

        Err.Clear

        Resume ErrorExit

    End If

End Sub