Excel精英培训网

 找回密码
 注册

QQ登录

只需一步,快速开始

你正在寻找更好的Excel学习教程吗?Excel技巧80集+数据透视表+函数初中高全套+VBA80集,想学的这儿全都有
查看: 359|回复: 5

[已解决] 按顺序分别执行宏1、宏2、宏3代码出错,可是这3个单独的宏分别执行时却没有错误。求教

[复制链接]
发表于 2017-1-10 22:52 | 显示全部楼层 |阅读模式
excel精英培训的微信平台,每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
本帖最后由 qiaodong64 于 2017-4-18 23:04 编辑

按顺序执行代码如下:
Sub ppp()
Call set1
Application.Wait (Now + TimeValue("00:00:3")) '3秒后运行宏二
Application.StatusBar = "……程序正在运行,请稍候……"
Call set2
Application.Wait (Now + TimeValue("00:00:3")) '3秒后运行宏三
Application.StatusBar = "……程序正在运行,请稍候……"
Call set3
Application.StatusBar = "程序运行结束"
End Sub
set1代码如下:
Sub set1()
Dim Wb As Workbook, sh As Worksheet, Wbnm As String
Dim Ends As Long, Mypath As String
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Mypath = ThisWorkbook.Path & "\"
Wbnm = Dir(Mypath & "*.xls*")
Do While Wbnm <> ""
    If Wbnm = ThisWorkbook.Name Then
    Set Wb = ActiveWorkbook
    Else
    Set Wb = Workbooks.Open(Mypath & Wbnm)
    End If
    For Each sh In Wb.Worksheets
        Ends = sh.Range("v65536").End(3).Row
        If sh.Range("v2") <> "1次" Then
            sh.Range("v2") = 1
            sh.Range("v2").Copy
            sh.Range("v3:v" & Ends).PasteSpecial Paste:=xlPasteAll, Operation:=xlMultiply, _
                    SkipBlanks:=False, Transpose:=False
            sh.Range("v2") = "1次"
            Wb.Save
        End If
        If Wbnm <> ThisWorkbook.Name Then Wb.Close
        Wbnm = Dir
    Next
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Set Wb = Nothing
End Sub
set2代码如下:

Sub set2()
    Dim ph$, fn$, sh As Worksheet
    ph = ThisWorkbook.Path & "\"
    fn = Dir(ph & "*.xls")
    Do While fn <> ""
        If fn <> ThisWorkbook.Name Then
            With Workbooks.Open(ph & fn)
                For Each sh In .Sheets
                    sh.UsedRange = sh.UsedRange.Value
                Next
                .Close True
            End With
        End If
        fn = Dir
    Loop
End Sub
set3代码如下:

Sub set3()
    Dim i As Integer, sh
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Range("a:ap").ClearContents
    Filename = Dir(ThisWorkbook.Path & "\*.xls")          '在本工作簿所在文件夹下(ThisWorkbook.Path)逐个查找excel文件
    Do While Filename <> ""                               '如果查找到存在第一个,则DO循环查找所有的
        If Filename <> ThisWorkbook.Name Then             '如果查找到的工作簿名称与本工作簿名称相同,则不进行复制
            fn = ThisWorkbook.Path & "\" & Filename       '工作簿完整路径及名称,以便下句打开工作簿
            Set Wb = Workbooks.Open(fn)                   '按上述fn值,打开指定文件夹下的工作簿
'                For Each sh In wb.Sheets
                    i = ThisWorkbook.Sheets("汇总").Range("vv3").End(xlToLeft).Column + 1
                    Range("bf:bf").Copy ThisWorkbook.Sheets("汇总").Cells(1, i)
                    Application.CutCopyMode = False
'                Next
            Wb.Close False                                '数据读取后,关闭打开的工作簿,False表示关闭时不进行保存
        End If
        Filename = Dir                                    '在当作工作簿所在文件夹下,循环打开下一个工作簿,循环到Do While Filename <> ""那句继续执行
    Loop
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub





新建文件夹.zip

440.54 KB, 下载次数: 2

发表于 2017-1-10 23:29 来自手机 | 显示全部楼层
解决方式1:间隔时间改成足够长
解决方式2:后2个过程,都放在if语句里。
两种方式都无法准确预计前一个过程的执行时间。
回复 支持 反对

使用道具 举报

发表于 2017-1-11 10:46 | 显示全部楼层
Sub ppp()
    Application.StatusBar = "……程序正在运行,请稍候……"
    Call set1
    Call set2
    Call set3
    Application.StatusBar = False
End Sub
回复 支持 反对

使用道具 举报

 楼主| 发表于 2017-1-11 23:30 | 显示全部楼层
爱疯 发表于 2017-1-11 10:46
Sub ppp()
    Application.StatusBar = "……程序正在运行,请稍候……"
    Call set1

执行到第三个宏代码时,提示下标越界 ,跟我一样。
回复 支持 反对

使用道具 举报

发表于 2017-1-12 09:08 | 显示全部楼层
有很多情况,可能造成下标越界。
比如,工作簿中并没有一个名称叫做"汇总"的工作表。


3楼代码放入1楼附件,没提示错误。
楼主应当先上传报错的附件,否则无法保证第一次就猜到原因。
回复 支持 反对

使用道具 举报

 楼主| 发表于 2017-1-12 09:57 | 显示全部楼层
爱疯 发表于 2017-1-12 09:08
有很多情况,可能造成下标越界。
比如,工作簿中并没有一个名称叫做"汇总"的工作表。

解释的很有道理,谢谢。
回复 支持 反对

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2017-6-26 13:11 , Processed in 0.124800 second(s), 22 queries , Gzip On, Memcache On.

Powered by Discuz! X3.2

© 2001-2013 Comsenz Inc.

快速回复 返回顶部 返回列表