Question

我使用以下代码将特定文件夹中的所有工作簿复制到一个工作簿中。 10次中有9次代码工作正常并且所有数据都被复制但偶尔宏似乎会提前退出而不会完成，因为msgbox永远不会显示，我也没有收到任何错误消息。该宏似乎已退出，因为它允许我运行其他宏。任何人都可以告诉我这可能是什么原因造成的？如果您在宏运行时开始在计算机上执行其他操作，似乎会发生这种情况。

Sub GetSheets()

Application.ScreenUpdating = False

Dim response
 response = MsgBox("This will take some time to run. Are you sure you want to proceed?", vbYesNo)
 If response = vbNo Then
 Exit Sub
 End If


Application.Run ("GetxlsxFiles")
Application.Run ("GetxlsFiles")

DataCopied = 1

Sheets("Instructions").Select

MsgBox "Completed Successfully"
End Sub

Sub GetxlsxFiles()
Dim Sheet As Worksheet
Path = Sheets("Instructions").Range("FileName").Value
Filename = Dir(Path & "*.xlsx")

Do While Filename <> ""
Workbooks.Open Filename:=Path & Filename, ReadOnly:=True, Password:="Password"
For Each Sheet In ActiveWorkbook.Sheets
Sheet.Copy After:=Workbooks("RSModel.xlsm").Sheets("Current KPIs")
Next Sheet

Workbooks(Filename).Close saveChanges:=False
Filename = Dir()
Loop

End Sub

getxlsfiles sub与上面的完全相同，但文件扩展名除外。

Answer 1

我已经重新编写了代码并在那里提供了评论评论中有太多不适合。

这是GetxlsxFiles Sub：
如果您删除解释我所做的事情的评论，这实际上很简短。

Sub GetxlsxFiles()
    Dim wb As Workbook, wbTemp As Workbook
    Dim Path As String, Filename As String ', masterWB As String
    Dim Sheet As Worksheet
    '~~> Assuming the path is correct
    Path = Sheets("Instructions").Range("FileName").Value
    '~~> Path should contain e.g. "C:\TestFolder\"
    Filename = Dir(Path & "*.xlsx")
    '~~> Assuming you are consolidating all sheets 
    '~~> in the workbook that contain the macro
    Set wb = ThisWorkbook
    '~~> If not, use the commented line below
    '~~> Take note that you do not include the file extension
    'Set wb = Workbooks("RSModel")
    '~~> Or you can also open it like this
    'masterWB = "C:\Foldername\RSModel.xlsm"
    'Set wb = Workbooks.Open(Filename:=masterWB, ReadOnly:=True)
    Do While Filename <> ""
        Set wbTemp = Workbooks.Open(Filename:=Path & Filename, ReadOnly:=True, _
                        Password:="Password")
        For Each Sheet In wbTemp.Sheets
            '~~> this adds the sheet after the last sheet in the target WB
            '~~> If you specifically want to add it after a specific sheet, 
            '~~> use the commented line
            Sheet.Copy After:=wb.Sheets(wb.Sheets.Count)
            'Sheet.Copy After:=wb.Sheets("Current KPIs")
        Next
        wbTemp.Close False
        Filename = Dir
    Loop

End Sub

以下是GetSheets Sub：

Sub GetSheets()
    Application.ScreenUpdating = False
    Dim response As Integer
    response = MsgBox("This will take some time to run." & vbNewLine & _
               "Are you sure you want to proceed?", vbYesNo)
    '~~> execute IF in one line
    If response = vbNo Then Exit Sub
    '~~> No need to use Application.Run. Call the subs directly
    GetxlsxFiles
    GetxlsFiles
    '~~> Not sure what's this for so I commented it
    'DataCopied = 1
    '~~> If you want below sheet to be selected then
    ThisWorkbook.Sheets("Instructions").Select
    MsgBox "Completed Successfully", vbInformation
End Sub

我认为上面应该接近你想要的希望这会有所帮助。

宏提前退出没有错误

1 个答案: