Vba 循环编码意外中止
我正在使用一个代码循环浏览用户指定文件夹中的所有文件并执行一项任务 代码开始执行,然后意外中止。第一次尝试在大约40个文件之后中止。第二次尝试多达177个文件。中止后,结果将显示到该点,并且是准确的 有人知道为什么它可能会中止和/或采用不同的解决方案吗。目标文件夹中约有7000个文件需要提取数据。请参阅下面的现有代码Vba 循环编码意外中止,vba,loops,excel,Vba,Loops,Excel,我正在使用一个代码循环浏览用户指定文件夹中的所有文件并执行一项任务 代码开始执行,然后意外中止。第一次尝试在大约40个文件之后中止。第二次尝试多达177个文件。中止后,结果将显示到该点,并且是准确的 有人知道为什么它可能会中止和/或采用不同的解决方案吗。目标文件夹中约有7000个文件需要提取数据。请参阅下面的现有代码 Sub LoopAllExcelFilesInFolder() 'PURPOSE: To loop through all Excel files in a user s
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
我已经获取了您的代码,并通过删除所有工作簿.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
我不知道这是否会节省足够的资源来完成你的长期任务,但它应该有一些改进