運行通過幾個文件循環的宏時，Excel崩潰

Question

我創建了一個宏，該宏打開幾個文件並將該文件中的數據複製到一個工作簿中。宏的工作方式是： 1）有一個主要工作簿（目標工作簿）和少量工作表，其中一個工作表包含B列中文件的路徑。單元格F1和H1包含兩個子文件夾，用戶可以指定這兩個單元格被添加到文件路徑中。文件的命名方式不同，但名稱中包含「One pager」。所以我使用文件路徑和通配符「One pager *」&「.xlsx」來打開文件。 2）宏檢查有多少行填充路徑，並循環遍歷具有路徑的行，打開每個文件（源工作簿），將指定的字段複製到主工作簿中的目標工作表中，然後關閉源文件。

宏工作正常，當我運行它一步一步或者當我設置一個斷點，並一次運行一個循環，但只要我通過5-6文件運行後運行完整的宏我的Excel崩潰。我試圖在4臺不同的計算機上運行同一個宏，其中兩臺運行宏時出現了excel崩潰，其中兩臺宏運行正常。兩臺電腦宏運行崩潰運行Windows 8.1 64位專業和兩個宏運行良好運行Windows 7 64和32位企業和所有計算機有Office 365.有人可以看看代碼，也許有一些我可以優化，使其工作所有電腦？ 預先感謝您

Private Sub GenerateReportOP() 
    Dim ThisWB As Workbook 
    Dim OnePager As Workbook 
    Dim ThisMacro As Worksheet 
    Dim ThisOnePage As Worksheet 
    Dim OnePagerWS As Worksheet 
    Dim LastRow1 As Long 
    Dim LastRow2 As Long 
    Dim LastRowZ As Long 
    Dim LastRowMOP As Long 
    Dim OPPath As String 
    Dim BSpath As String 
    Dim Rates As String 
    Dim i As Integer 
    Dim SubstrinLoc As Integer 

    Application.ScreenUpdating = False 
    Application.AskToUpdateLinks = False 
    Application.DisplayAlerts = False 
    Application.EnableEvents = False 
    Application.Calculation = xlManual 

    Set ThisWB = ThisWorkbook 
    Set ThisMacro = ThisWB.Sheets("Macros") 
    Set ThisOnePage = ThisWB.Sheets("One Pagers") 

    ThisOnePage.Cells.Clear 
    LastRowMOP = ThisMacro.Range("B" & Rows.Count).End(xlUp).Row 

    i = 3 
    Do While i <= LastRowMOP 
    LastRow1 = ThisOnePage.Range("B" & Rows.Count).End(xlUp).Row 
    If ThisMacro.Range("B" & i) <> "" Then 
    ThisOnePage.Range("B" & LastRow1 + 1) = ThisMacro.Range("A" & i) 
    ThisOnePage.Range("C" & LastRow1 + 1).Value = "FX:" 
    'just formating section 
    ThisOnePage.Range("B" & LastRow1 + 1).Font.Bold = True 
    ThisOnePage.Range("B" & LastRow1 + 1).Font.Color = vbRed 
    ThisOnePage.Range("B" & LastRow1 + 1).Font.Size = 14 
    ThisOnePage.Range("C" & LastRow1 + 1).Font.Bold = True 
    ThisOnePage.Range("C" & LastRow1 + 1).Font.Color = vbRed 
    ThisOnePage.Range("C" & LastRow1 + 1).Font.Size = 14 
    'Define one pager workbook 
    OPPath = ThisMacro.Range("B" & i) & ThisMacro.Range("F1") & "\" & ThisMacro.Range("H1") & "\" 
    'error handler if path is not correct 
    On Error GoTo Error_handler: 
    Set OnePager = Workbooks.Open(OPPath & "*One Pager*" & ".xlsx") 
    Set OnePagerWS = OnePager.Worksheets("Check list") 
    LastRow2 = OnePagerWS.Range("A" & Rows.Count).End(xlUp).Row 
    LastRowZ = OnePagerWS.Range("Z" & Rows.Count).End(xlUp).Row 
    'check what ratees is linked 
    Rates = OnePagerWS.Range("S8").Formula 
    SubstrinLoc = InStr(1, Rates, "FY") 
    ThisOnePage.Range("D" & LastRow1 + 1) = Mid(Rates, SubstrinLoc + 6, 13) 
    ThisOnePage.Range("D" & LastRow1 + 1).Font.Bold = True 
    ThisOnePage.Range("D" & LastRow1 + 1).Font.Color = vbBlue 
    ThisOnePage.Range("D" & LastRow1 + 1).Font.Size = 14 
    'copy one pager 
    OnePagerWS.Range("D4").Copy 
    ThisOnePage.Range("I" & LastRow1 + 3).PasteSpecial xlPasteValues 
    ThisOnePage.Range("I" & LastRow1 + 3).PasteSpecial xlPasteFormats 
    OnePagerWS.Range("A6:A" & LastRow2).Copy Destination:=ThisOnePage.Range("B" & LastRow1 + 2) 
    OnePagerWS.Range("J6:J" & LastRow2).Copy 
    ThisOnePage.Range("C" & LastRow1 + 2).PasteSpecial xlPasteValues 
    ThisOnePage.Range("C" & LastRow1 + 2).PasteSpecial xlPasteFormats 
    OnePagerWS.Range("L6:L" & LastRow2).Copy 
    ThisOnePage.Range("D" & LastRow1 + 2).PasteSpecial xlPasteValues 
    ThisOnePage.Range("D" & LastRow1 + 2).PasteSpecial xlPasteFormats 
    OnePagerWS.Range("N6:N" & LastRow2).Copy 
    ThisOnePage.Range("E" & LastRow1 + 2).PasteSpecial xlPasteValues 
    ThisOnePage.Range("E" & LastRow1 + 2).PasteSpecial xlPasteFormats 
    OnePagerWS.Range("Q6:Q" & LastRow2).Copy 
    ThisOnePage.Range("F" & LastRow1 + 2).PasteSpecial xlPasteValues 
    ThisOnePage.Range("F" & LastRow1 + 2).PasteSpecial xlPasteFormats 
    OnePagerWS.Range("S6:S" & LastRow2).Copy 
    ThisOnePage.Range("G" & LastRow1 + 2).PasteSpecial xlPasteValues 
    ThisOnePage.Range("G" & LastRow1 + 2).PasteSpecial xlPasteFormats 
    OnePagerWS.Range("T6:T" & LastRow2).Copy 
    ThisOnePage.Range("H" & LastRow1 + 2).PasteSpecial xlPasteValues 
    ThisOnePage.Range("H" & LastRow1 + 2).PasteSpecial xlPasteFormats 
    OnePagerWS.Range("Z" & LastRowZ).Copy 
    ThisOnePage.Range("I" & LastRow1 + 2).PasteSpecial xlPasteValues 
    ThisOnePage.Range("I" & LastRow1 + 2).PasteSpecial xlPasteFormats 
    LastRow2 = ThisOnePage.Range("B" & Rows.Count).End(xlUp).Row 
    With ThisOnePage 
     .Range(.Cells(LastRow1 + 4, 1), .Cells(LastRow2, 1)) = ThisMacro.Range("A" & i) 
    End With 
    Application.CutCopyMode = False 
    OnePager.Close savechanges:=False 

    'error handler if path is not correct 
Error_handler: 
     If ThisOnePage.Range("D" & LastRow1 + 1) = "" Then 
      ThisOnePage.Range("C" & LastRow1 + 1).Value = "Unable to find One Pager, please check file or path!" 
     End If 
     Resume Next 
    End If 

    i = i + 1 
    Loop 
    ThisOnePage.Range("A:I").EntireColumn.AutoFit 
    Application.AskToUpdateLinks = True 
    Application.DisplayAlerts = True 
    Application.EnableEvents = True 
    Application.Calculation = xlAutomatic 

    MsgBox "Finished. Please check ""One Pagers"" tab." 
End Sub 

Answer 1

嘛，Excel中不應該崩潰，但在現實世界中，如果你把它。我會重寫代碼以使其更安全，而不是運行實驗。

那麼如何讓你的代碼更安全。好吧，我猜測你的問題可能在於你是用拷貝和粘貼來打亂剪貼板。我幾乎從未在生產中複製和粘貼代碼。如果我想將單元格從源複製到目標，那麼我使用Range.Value2批量get/set。所以一個例子是

Range("Destination").Value2 = Range("Source").Value2 

您需要確保源和目標範圍具有完全相同的尺寸。因此，請將此類代碼替換爲您的複製和粘貼值。 另外，使用VBA代碼格式化單元格，而不是從剪貼板複製。

看看是否修復它。發佈反饋。

Answer 2

@S Meaden是正確的，你應該儘量避免.Copy + .Paste在可能的情況下。

但是，既然你想要的格式，我想這實際上是複製+粘貼有意義的罕見情況之一。

我認爲您的問題本身不是.Copy，而是OnePager工作簿的重複.Open + .Close。

當我遇到類似問題時，我的Excel沒有完全崩潰，宏只是隨機停止而沒有觸發錯誤處理程序。

我會嘗試以下方法：

• 進入循環使用該應用
• 打開你的OnePager-文件之前打開一個新的Excel，並粘貼到您現有的Excel

。希望幫助！

這裏是你如何調整你的代碼：

Private Sub GenerateReportOP() 

    '... your code 

    ' open a new Excel in which you open the files 
    Dim xlApp As New Excel.Application 
    i = 3 
    Do While i <= LastRowMOP 

     '... your code 

     ' change: repeatedly open the files in your new excel app 
     Set OnePager = xlApp.Workbooks.Workbooks.Open(OPPath & "*One Pager*" & ".xlsx") 

     '... your code 

     xlApp.CutCopyMode = False 
     OnePager.Close savechanges:=False 

     '... your code 

    i = i + 1 
    Loop 

    ' close the new excel after you're done looping. always close it (w/ errorhandler), so you dont have to shut it down with the task manager 
    xlApp.Quit 
    Set xlApp = Nothing 

    '... your code 

    MsgBox "Finished. Please check ""One Pagers"" tab." 
End Sub 

而且，閱讀this應加快您的編碼相當多的將有可能使你的代碼更易讀

Answer 3

謝謝大家的幫助。我結合了Darren和S Maeden的兩個建議。 我改變了我的錯誤處理程序，並使宏直接將數據複製到單元格中，避免使用剪貼板。我只是工作的一部分格式化現在

OPPath = ThisMacro.Range("B" & i) & ThisMacro.Range("F1") & "\" & ThisMacro.Range("H1") & "\" 
     'error handler if path is not correct 
     On Error Resume Next 
     Set OnePager = Workbooks.Open(OPPath & "*One Pager*" & ".xlsx") 
     If Err.Number = 1004 Then 
      If ThisOnePage.Range("D" & LastRow1 + 1) = "" Then 
       ThisOnePage.Range("C" & LastRow1 + 1).Value = "Unable to find One Pager, please check file or path!" 
      End If 
     Else 
      Set OnePagerWS = OnePager.Worksheets("Check list") 
      LastRow2 = OnePagerWS.Range("A" & Rows.Count).End(xlUp).Row 
      LastRowZ = OnePagerWS.Range("Z" & Rows.Count).End(xlUp).Row 
      'check what rates is linked 
      Rates = OnePagerWS.Range("S9").Formula 
      SubstrinLoc = InStr(1, Rates, "FY") 
      ThisOnePage.Range("D" & LastRow1 + 1) = Mid(Rates, SubstrinLoc + 6, 13) 
      ThisOnePage.Range("D" & LastRow1 + 1).Font.Bold = True 
      ThisOnePage.Range("D" & LastRow1 + 1).Font.Color = vbBlue 
      ThisOnePage.Range("D" & LastRow1 + 1).Font.Size = 14 
      'copy one pager 
      ThisOnePage.Range("I" & LastRow1 + 2).Value = OnePagerWS.Range("D4").Value 

      ThisOnePage.Range("B" & LastRow1 + 2 & ":B" & LastRow1 + LastRow2 - 4).Value = OnePagerWS.Range("A6:A" & LastRow2).Value 

      ThisOnePage.Range("C" & LastRow1 + 2 & ":C" & LastRow1 + LastRow2 - 4).Value = OnePagerWS.Range("J6:J" & LastRow2).Value 
      ThisOnePage.Range("C" & LastRow1 + 2 & ":C" & LastRow1 + LastRow2 - 4).NumberFormat = "0" 
      ThisOnePage.Range("D" & LastRow1 + 2 & ":D" & LastRow1 + LastRow2 - 4).Value = OnePagerWS.Range("L6:L" & LastRow2).Value 
      ThisOnePage.Range("D" & LastRow1 + 2 & ":C" & LastRow1 + LastRow2 - 4).NumberFormat = "0" 
      ThisOnePage.Range("E" & LastRow1 + 2 & ":E" & LastRow1 + LastRow2 - 4).Value = OnePagerWS.Range("N6:N" & LastRow2).Value 

      ThisOnePage.Range("F" & LastRow1 + 2 & ":F" & LastRow1 + LastRow2 - 4).Value = OnePagerWS.Range("Q6:Q" & LastRow2).Value 

      ThisOnePage.Range("G" & LastRow1 + 2 & ":G" & LastRow1 + LastRow2 - 4).Value = OnePagerWS.Range("S6:S" & LastRow2).Value 

      ThisOnePage.Range("H" & LastRow1 + 2).Value = OnePagerWS.Range("T6:T" & LastRow2).Value 

      ThisOnePage.Range("J" & LastRow1 + 2).Value = OnePagerWS.Range("Z" & LastRowZ).Value 

      LastRow2 = ThisOnePage.Range("B" & Rows.Count).End(xlUp).Row 
      With ThisOnePage 
       .Range(.Cells(LastRow1 + 4, 1), .Cells(LastRow2, 1)) = ThisMacro.Range("A" & i) 
      End With 
      Application.CutCopyMode = False 
      OnePager.Close savechanges:=False 
     End If 
    End If 

    i = i + 1 
    Loop