码迷,mamicode.com
首页 > 编程语言 > 详细

20161227xlVBA多文件合并计算

时间:2017-07-07 21:42:03      阅读:224      评论:0      收藏:0      [点我收藏+]

标签:star   upd   auto   文件   ber   double   time   resume   cti   

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多文件合并计算

标签:star   upd   auto   文件   ber   double   time   resume   cti   

原文地址:http://www.cnblogs.com/nextseven/p/7133845.html

(0)
(0)
   
举报
评论 一句话评论(0
登录后才能评论!
© 2014 mamicode.com 版权所有  联系我们:gaon5@hotmail.com
迷上了代码!