F5运行失败但F8一步步运行没出错

daqinqin

下面这段代码其实就是解压压缩包到相应的文件夹内，然后对这些压缩包和文件夹进行改名，最后将解压的文件夹中的某个文件提取出来。
问题在于按f8能成功，但是f5不能成功。脑壳疼。这些程序分开运行能成功，合在一起就有问题了。
不知哪位大佬来解答一下。自学vba中的一个坎。

Sub f5f8()
    Application.ScreenUpdating = False

    PRD = "10Jan2019"
    arr = Array("SH", "WX") '创建各地区压缩包的列表
    rarexe = "D:\ruanjian\7-Zip\7z.exe" 'rar程序路径

    For dtn = 0 To UBound(arr) '遍历解压文件
        filerar = ThisWorkbook.Path & "\报告表" & arr(dtn) & ".*"
        If Dir(filerar) <> "" Then
            VBA.MkDir (ThisWorkbook.Path & "\报告表" & arr(dtn))  '创建文件夹
            filepath = ThisWorkbook.Path & "\报告表" & arr(dtn) & "\"  '解压的位置
            filestring = rarexe & " e " & filerar & " -o" & filepath
            result = Shell(filestring, vbHide)

        End If
    Next

    '傻瓜式改名
        On Error Resume Next
        Name ThisWorkbook.Path & "\报告表WX.rar" As ThisWorkbook.Path & "\报告表 (date=" & PRD & ") from WX.rar"
        Name ThisWorkbook.Path & "\报告表SH.rar" As ThisWorkbook.Path & "\报告表 (date=" & PRD & ") from SH.rar"
        Name ThisWorkbook.Path & "\报告表WX" As ThisWorkbook.Path & "\报告表 (date=" & PRD & ") from WX"
        Name ThisWorkbook.Path & "\报告表SH" As ThisWorkbook.Path & "\报告表 (date=" & PRD & ") from SH"

    '将汇总表复制出来
    For dtn_pdf = 0 To UBound(arr) '遍历解压文件
            file_sum = ThisWorkbook.Path & "\报告表 (date=" & PRD & ") from " & arr(dtn_pdf)        
            sum_sht = Dir(file_sum & "\报告汇总*.*")
            FileCopy file_sum & "\" & sum_sht, ThisWorkbook.Path & "\报告汇总 (date=" & PRD & ") from " & arr(dtn_pdf) & ".xlsx"  
            sum_sht = Dir     
    Next   
    Application.ScreenUpdating = True

End Sub

hfwufanhf2006

测试不了，别人的电脑也不一定用7Z这个软件，多数人用rar

daqinqin

改成winrar的有人能成功么
Sub f5f8()
    Application.ScreenUpdating = False

    PRD = "10Jan2019"
    arr = Array("SH", "WX") '创建各地区压缩包的列表
    rarexe = "D:\ruanjian\WinRAR.exe" 'rar程序路径

    For dtn = 0 To UBound(arr) '遍历解压文件
        filerar = ThisWorkbook.Path & "\报告表" & arr(dtn) & ".*"
        If Dir(filerar) <> "" Then
            VBA.MkDir (ThisWorkbook.Path & "\报告表" & arr(dtn))  '创建文件夹
            filepath = ThisWorkbook.Path & "\报告表" & arr(dtn) & "\"  '解压的位置
            filestring = rarexe & " x -ep " & filerar & filepath
            result = Shell(filestring, vbHide)

        End If
    Next

    '傻瓜式改名
        On Error Resume Next
        Name ThisWorkbook.Path & "\报告表WX.rar" As ThisWorkbook.Path & "\报告表 (date=" & PRD & ") from WX.rar"
        Name ThisWorkbook.Path & "\报告表SH.rar" As ThisWorkbook.Path & "\报告表 (date=" & PRD & ") from SH.rar"
        Name ThisWorkbook.Path & "\报告表WX" As ThisWorkbook.Path & "\报告表 (date=" & PRD & ") from WX"
        Name ThisWorkbook.Path & "\报告表SH" As ThisWorkbook.Path & "\报告表 (date=" & PRD & ") from SH"

    '将汇总表复制出来
    For dtn_pdf = 0 To UBound(arr) '遍历解压文件
            file_sum = ThisWorkbook.Path & "\报告表 (date=" & PRD & ") from " & arr(dtn_pdf)        
            sum_sht = Dir(file_sum & "\报告汇总*.*")
            FileCopy file_sum & "\" & sum_sht, ThisWorkbook.Path & "\报告汇总 (date=" & PRD & ") from " & arr(dtn_pdf) & ".xlsx"  
            sum_sht = Dir     
    Next   
    Application.ScreenUpdating = True

End Sub

daqinqin

终于知道原因了，原来是shell调用外部程序比较慢，但是后面的程序已经开始运行了。下面在网上找到了两种方法
1. 添加createobject，原网页：http://www.exceltip.net/thread-6997-1-1.html

• Sub ListAD()
• Set oShell = CreateObject("WSCript.shell")
• ret = oShell.Run("cmd.exe /c dir c: /ad  > c:\list.txt", 0, True)    '第三参数设置为True表示等待程序结束
• Open "c:\list.txt" For Input As #1
• MsgBox StrConv(InputB$(LOF(1), 1), vbUnicode)
• Close #1
• Kill "c:\list.txt"
• Set oShell = Nothing
• End Sub
  

2. 百度文库也有，不过有点复杂：https://wenku.baidu.com/view/5257271110a6f524ccbf85c3.html