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

20161227xlVBA多文件合並計算