循环编码意外中止
我正在使用代码来遍历用户指定文件夹中的所有文件并执行任务。
代码开始执行，然后意外中止。 大约40个文件后，第一次尝试中止。 第二次尝试达到了177个文件。 当中止的结果，这一点出现，是准确的。
有没有人有任何想法，为什么它可能会中止和/或一个不同的解决scheme。 目标文件夹有大约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 我已经把你的代码和删除所有的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
我不知道这是否会节省足够的资源来完成你的长期任务，但应该做一些改进。