20161227xlVBA多文件合并计算

Posted 2020-09-27 Excel VBA 小天地

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