1
我正在使用代码遍历用户指定文件夹中的所有文件并执行任务。循环编码意外中止
代码开始执行,然后意外中止。大约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