循環編碼意外中止

Question

我正在使用代碼遍歷用戶指定文件夾中的所有文件並執行任務。

代碼開始執行，然後意外中止。大約40個文件後，第一次嘗試中止。第二次嘗試達到了177個文件。當中止結果時，出現並且準確。

有沒有人有任何想法，爲什麼它可能會中止和/或不同的解決方案。目標文件夾中有大約7000個需要提取數據的文件。請參閱以下現有代碼。

Sub LoopAllExcelFilesInFolder() 

    'PURPOSE: To loop through all Excel files in a user specified folder and perform a set task on them 

    Dim wb As Workbook 
    Dim myPath As String 
    Dim myFile As String 
    Dim myExtension As String 
    Dim Folder As String 
    Dim MacroFile As String 
    Dim RowCTR As Integer 

    MacroFile = "Transportation Contact List.xlsm" 

    Application.ScreenUpdating = False 
    Application.Calculation = xlCalculationManual 

    'Retrieve Target Folder Path From User 
    Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker) 

    With FldrPicker 
     .Title = "Select A Target Folder" 
     .AllowMultiSelect = False 
     If .Show <> -1 Then GoTo NextCode 
     myPath = .SelectedItems(1) & "\" 
    End With 

    'In Case of Cancel 
NextCode: 
    myPath = myPath 
    If myPath = "" Then GoTo ResetSettings 

    'Target File Extension (must include wildcard "*") 
    myExtension = "*.xls" 

    'Target Path with Ending Extention 
    myFile = Dir(myPath & myExtension) 

    RowCTR = 2 
    'Loop through each Excel file in folder 
    Do While myFile <> "" 
     'Set variable equal to opened workbook 
     Set wb = Workbooks.Open(Filename:=myPath & myFile) 

     'Windows("\\ATLP3FILE5\shared\AITransport\AITFILES_mig-103009\AITUW\LDM\CIF").Activate 
     'CUT AND PASTE SECTION 

     Workbooks(myFile).Activate 
     Worksheets("CIF").Range("F5").Copy 
     Workbooks(MacroFile).Worksheets("Sheet1").Range("A" & RowCTR).PasteSpecial (xlPasteValues) 

     Workbooks(myFile).Activate 
     Worksheets("CIF").Range("h10").Copy 
     Workbooks(MacroFile).Worksheets("Sheet1").Range("B" & RowCTR).PasteSpecial (xlPasteValues) 

     Workbooks(myFile).Activate 
     Worksheets("CIF").Range("h12").Copy 
     Workbooks(MacroFile).Worksheets("Sheet1").Range("C" & RowCTR).PasteSpecial (xlPasteValues) 

     Workbooks(myFile).Activate 
     Worksheets("CIF").Range("D13").Copy 
     Workbooks(MacroFile).Worksheets("Sheet1").Range("D" & RowCTR).PasteSpecial (xlPasteValues) 

     Workbooks(myFile).Activate 
     Worksheets("CIF").Range("s64").Copy 
     Workbooks(MacroFile).Worksheets("Sheet1").Range("E" & RowCTR).PasteSpecial (xlPasteValues) 

     Workbooks(myFile).Activate 
     Worksheets("CIF").Range("Y5").Copy 
     Workbooks(MacroFile).Worksheets("Sheet1").Range("F" & RowCTR).PasteSpecial (xlPasteValues) 

     Workbooks(myFile).Activate 
     Worksheets("CIF").Range("X10").Copy 
     Workbooks(MacroFile).Worksheets("Sheet1").Range("G" & RowCTR).PasteSpecial (xlPasteValues) 

     Workbooks(myFile).Activate 
     Worksheets("CIF").Range("AB11").Copy 
     Workbooks(MacroFile).Worksheets("Sheet1").Range("H" & RowCTR).PasteSpecial (xlPasteValues) 

     Workbooks(myFile).Activate 
     Worksheets("CIF").Range("W9").Copy 
     Workbooks(MacroFile).Worksheets("Sheet1").Range("I" & RowCTR).PasteSpecial (xlPasteValues) 

     Workbooks(myFile).Activate 

     'Save and Close Workbook 
     wb.Close SaveChanges:=False 

     'Get next file name 
     myFile = Dir 
     RowCTR = RowCTR + 1 
    Loop 

    'Message Box when tasks are completed 
    MsgBox "Task Complete!" 

ResetSettings: 
    'Reset Macro Optimization Settings 
    Application.ScreenUpdating = True 
    Application.Calculation = xlCalculationAutomatic 

End Sub 

Answer 1

我已經拿走了你的代碼，並通過刪除所有的workbook.activate命令來收緊它。同樣，我使用直接值轉移代替剪貼板的副本&粘貼特殊值。

Sub LoopAllExcelFilesInFolder() 

    'PURPOSE: To loop through all Excel files in a user specified folder and perform a set task on them 

    Dim wb As Workbook, wsMFS1 As Worksheet 
    Dim myPath As String 
    Dim myFile As String 
    Dim myExtension As String 
    Dim Folder As String 
    Dim MacroFile As String 
    Dim RowCTR As Integer 

    MacroFile = "Transportation Contact List.xlsm" 

    Application.ScreenUpdating = False 
    Application.Calculation = xlCalculationManual 

    'Retrieve Target Folder Path From User 
    Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker) 

    With FldrPicker 
     .Title = "Select A Target Folder" 
     .AllowMultiSelect = False 
     If .Show <> -1 Then GoTo NextCode 
     myPath = .SelectedItems(1) & "\" 
    End With 

    'In Case of Cancel 
NextCode: 
     myPath = myPath 
     If myPath = "" Then GoTo ResetSettings 

    'Target File Extension (must include wildcard "*") 
     myExtension = "*.xls" 

    'Target Path with Ending Extention 
     myFile = Dir(myPath & myExtension) 

    RowCTR = 2 
    Set wbMF = Workbooks(MacroFile).Worksheets("Sheet1") 
    'Loop through each Excel file in folder 
    Do While CBool(Len(myFile)) 
     'Set variable equal to opened workbook 
      Set wb = Workbooks.Open(Filename:=myPath & myFile) 
     With wb.Worksheets("CIF") 

      'Windows("\\ATLP3FILE5\shared\AITransport\AITFILES_mig-103009\AITUW\LDM\CIF").Activate 
      'CUT AND PASTE SECTION 

      wsMFS1.Range("A" & RowCTR) = .Range("F5").Value 
      wsMFS1.Range("B" & RowCTR) = .Range("H10").Value 
      wsMFS1.Range("C" & RowCTR) = .Range("H12").Value 
      wsMFS1.Range("D" & RowCTR) = .Range("D13").Value 
      wsMFS1.Range("E" & RowCTR) = .Range("S64").Value 
      wsMFS1.Range("F" & RowCTR) = .Range("Y5").Value 
      wsMFS1.Range("G" & RowCTR) = .Range("X10").Value 
      wsMFS1.Range("H" & RowCTR) = .Range("AB11").Value 
      wsMFS1.Range("I" & RowCTR) = .Range("W9").Value 

     End With 

     'Save and Close Workbook 
     wb.Close SaveChanges:=False 
     Set wb = Nothing 
     'Get next file name 
     myFile = Dir 
     RowCTR = RowCTR + 1 
    Loop 
    Set wbMF = Nothing 

    'Message Box when tasks are completed 
    MsgBox "Task Complete!" 

ResetSettings: 
     'Reset Macro Optimization Settings 
    Application.ScreenUpdating = True 
    Application.Calculation = xlCalculationAutomatic 

End Sub 

我不知道這是否會節省足夠的資源來完成您的長期任務，但它應該做一些改進。