多簿多表合并运行时怎么消除提示

billyzyq

根据网上大师提供的代码，修改了一个多簿多表合并的代码，但在运行时总是有如图提示，不知如何取消？还清各位大师出手相助。

方便的话请在原MsgBox增加一个运行时间的提示，已合并多少工作簿，多长时间。

代码如下：
Sub 合并()
   
    Dim MyPath, MyName, AWbName
    Dim Wb As Workbook, WbN As String
    Dim G As Long, k As Integer
    Dim Num As Long
    Dim BOX As String
    Dim i As Integer, x As Integer
    Application.ScreenUpdating = False
    MyPath = ActiveWorkbook.Path
    MyName = Dir(MyPath & "\" & "*.xls?")
    AWbName = ActiveWorkbook.Name
    Num = 0
    Do While MyName <> ""
        If MyName <> AWbName Then
            Set Wb = Workbooks.Open(MyPath & "\" & MyName)
            Num = Num + 1
            With Workbooks(1).ActiveSheet
                .Cells(.Range("B" & Rows.Count).End(xlUp).Row + 2, 1) = Left(MyName, Len(MyName) - 4)
                For G = 1 To Sheets.Count
                    'k = k + 1
                    If Sheets(G).Name <> "代码" Then
                    'If k = 1 Then '如果第一次复制，就进行复制标题
                       ' Wb.Sheets(G).UsedRange.Copy .Cells(.Range("B" & Rows.Count).End(xlUp).Row + 1, 1)
                   ' Else '否则就下移一行.Offset(1)，1为标题实际行数
                        Wb.Sheets(G).UsedRange.Offset(1).Copy .Cells(.Range("B" & Rows.Count).End(xlUp).Row + 1, 1)
                    End If
                Next
                WbN = WbN & Chr(13) & Wb.Name
                Wb.Close False
            End With
        End If
        MyName = Dir
    Loop
    Range("B1").Select
    Application.ScreenUpdating = True

    i = Range("b1500").End(xlUp).Row
    For x = i To 2 Step -1
      If Range("b" & x).Value = "合计" Then
         Range("b" & x).EntireRow.Delete
    End If
      If Range("b" & x).Value = "" Then
         Range("b" & x).EntireRow.Delete
    End If
Next x
MsgBox "共合并了" & Num & "个工作薄下的全部工作表。如下：" & Chr(13) & WbN, vbInformation, "提示"
End Sub

测试.rar (118.43 KB, 下载次数: 76)

2018-5-28 11:07 上传

点击文件名下载附件

opiona

1.      Rem 禁止系统刷屏?触发其他事件等
   
2.     'On Error Resume Next    '// 发生错误，自动执行下一句，就是忽略错误
   
3.     Application.ScreenUpdating = False '//关闭屏幕刷新
   
4.     Application.DisplayAlerts = False '//关闭系统提示
   
5.     Application.EnableEvents = False  '//禁止触发其他事件
   
6.     Application.StatusBar = True   '关闭系统状态条
   
7.     Application.Calculation = xlManual     '//xlCalculationManual  用户请求时进行计算
   
8. 
   
9. 
   
10.     Dim T
    
11.     T = Timer   '//开始时间
    
12. 
    
13.     Rem  提示信息，在状态栏显示
    
14.     Rem Application.StatusBar = "文件总数：" & ICINT & " 当前是第：" & I + 1 & " 当前提取的文件是：" & GetPathFromFileName(FileArr(I), True)  '
    
15.     Rem  DoEvents
    
16. 
    
17.     Application.Calculation = xlAutomatic  '//xlCalculationAutomaticExcel 控制重新计算。
    
18.     Application.StatusBar = False   '恢复系统状态条
    
19.     Application.EnableEvents = True  '//  '//恢复触发其他事件
    
20.     Application.ScreenUpdating = True '//恢复屏幕刷新
    
21.     Application.DisplayAlerts = True '//恢复系统提示
    
22.     MsgBox "一共用时：" & Format(Timer - T, "#0.0000") & " 秒", , "北极狐提示!!"  '//提示所用时间

复制代码

billyzyq

十分感谢大师的指导。
好好学习消化。
可惜没有鲜花可送，再一次送上感激。

lsc900707

billyzyq 发表于 2018-5-29 15:20
十分感谢大师的指导。
好好学习消化。
可惜没有鲜花可送，再一次送上感激。

新人也可送花呀，点击对方帖子右下角“评分”，按提示操作即可。

billyzyq

lsc900707老师也是高手，哪天也请你指导指导。

abs44

多簿多表合并可以提供个修正好的么？我看不懂，只能用别人的完成作品了，谢谢。ieyhi@163.com