not my code completely.borrowed it from net with my changes in between
PURPOSE: To loop through all Excel files in a user specified folder and
perform a set task on them
SOURCE: www.TheSpreadsheetGuru.com
Sub LoopAllExcelFilesInFolder()
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
Application.EnableEvents = False
'Retrieve Target Folder Path From User
myPath = ThisWorkbook.Worksheets(1).Range("B1").Value & "\" &
ThisWorkbook.Worksheets(1).Range("B2").Value & "\" &
ThisWorkbook.Worksheets(1).Range("B3").Value & "\"
End Sub
not my code completely.borrowed it from net with my changes in between
PURPOSE: To loop through all Excel files in a user specified folder and
perform a set task on them
SOURCE: www.TheSpreadsheetGuru.com
Sub LoopAllExcelFilesInFolder()
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
Application.EnableEvents = False
'Retrieve Target Folder Path From User
myPath = ThisWorkbook.Worksheets(1).Range("B1").Value & "\" &
ThisWorkbook.Worksheets(1).Range("B2").Value & "\" &
ThisWorkbook.Worksheets(1).Range("B3").Value & "\"
'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)
'Loop through each Excel file in folder
Do While myFile <> ""
'Set variable equal to opened workbook
Set wb = Workbooks.Open(Filename:=myPath & myFile)
WS_Count = wb.Worksheets.Count
' Begin the loop.
'Ensure Workbook has opened before moving on to next line of code
DoEvents
For I = 1 To WS_Count
'Change First Worksheet's Background Fill Blue
'following snippet arranges data in the 4th row and colors it
With wb.Worksheets(I)
If (Range("A1") <> "") Then
'Find the last used row in a Column: column A in this example
Dim LastRow As Long
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
Dim LastCol As Integer
LastCol = Cells(1, Columns.Count).End(xlToLeft).Column
LastColcell = Cells(1, LastCol).Address
Range("A1:" & LastColcell).Font.Color = vbWhite
Range("A1:" & LastColcell).Interior.Color = RGB(51, 98, 174)
Rows("1:3").Insert Shift:=xlDown
Range("G1").FormulaR1C1 = "=SUBTOTAL(9,R[5]C:R[" & LastRow & "]C)"
Range("G1").AutoFill Destination:=Range("G1:" & LastColcell)
Range("G1:" & LastColcell).Interior.Color = RGB(255, 255, 0)
AutoFilterMode = False
End If
End With
Next I
'Save and Close Workbook
Dt = Format(Date, "yyyymmdd")
wb.Close SaveChanges:=True
'Ensure Workbook has closed before moving on to next line of code
DoEvents
'Get next file name
myFile = Dir
Loop
'Message Box when tasks are completed
MsgBox "Task Complete!"
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Related
I am trying to develop a macro which will open excel files specified by user-prompted location, find a specific column and paste the entire column in the active workbook. So far I have written the code which can loop through the files in the directory, opens the file, search for the column and store the entire column in an array. Now whenever I am trying a Run Time Error saying "Overflow"! Can anyone help me to fix this issue? Also, I want to integrate below item in the macro:
1. Find multiple columns from each file and paste those columns in a sheet. So for multiple files, I should paste the columns in individual worksheet dynamically. How can I do that? Any help is appreciated. Thanks. Below is my code I have written so far:
Sub Test_Template()
'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, myFile As String
Dim myExtension As String
Dim t As Range, rng As Range, rng2 As Range
Dim dblAvg As Single, eng_spd As Single, i As Integer
Dim FldrPicker As FileDialog
Dim rowCtr As Integer
Dim myarray1 As Variant
rowCtr = 2
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = 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)
'Loop through each Excel file in folder
Execute:
Do While myFile <> ""
'Set variable equal to opened workbook
Set wb = Workbooks.Open(Filename:=myPath & myFile)
'Ensure Workbook has opened before moving on to next line of code
DoEvents
'Find "Time" in Row 1
With wb.Worksheets(1).Rows(9)
Set t = .Find("Time", lookat:=xlPart)
'If found, copy the column to Sheet 2, Column A
'If not found, present a message
If Not t Is Nothing Then
'Columns(t.Column).EntireColumn.Copy _
' Destination:=Sheets(3).Range("A1")
Set rng2 = Columns(t.Column)
myarray1 = rng2
Else: MsgBox "Time Not Found"
End If
End With
'Save and Close Workbook
wb.Close 'SaveChanges:=True
'Ensure Workbook has closed before moving on to next line of code
DoEvents
With ActiveSheet
For i = LBound(myarray1) To UBound(myarray1)
Debug.Print myarray1(i, 1)
Next
End With
'Get next file name
myFile = Dir
Loop
'Message Box when tasks are completed
'MsgBox "Task Complete!"
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
here is your code with clutter, like goto commands, and unused With commands removed
Sub Test_Template()
'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, myFile As String
Dim myExtension As String
Dim t As Range, rng As Range, rng2 As Range
Dim dblAvg As Single, eng_spd As Single, i As Long
Dim FldrPicker As FileDialog
Dim rowCtr As Long
Dim myarray1 As Variant
rowCtr = 2
' Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = 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 = True Then
myPath = .SelectedItems(1) & "\"
End If
End With
myPath = myPath ' In Case of Cancel
If myPath <> "" Then
myExtension = "*.xls*" ' Target File Extension (must include wildcard "*")
myFile = Dir(myPath & myExtension) ' Target Path with Ending Extention
Do While myFile <> "" ' Loop through each Excel file in folder
Set wb = Workbooks.Open(Filename:=myPath & myFile) ' Set variable equal to opened workbook
DoEvents ' yield processing time to other events
Set t = wb.Worksheets(1).Rows(9).Find("Time", lookat:=xlPart) ' Find "Time" in Row 1 ????
If Not t Is Nothing Then
' Columns(t.Column).EntireColumn.Copy _
Destination:=Sheets(3).Range("A1")
myarray1 = Columns(t.Column) ' found: copy the column to Sheet 2, Column A
Else
MsgBox "Time Not Found"
End If
wb.Close ' SaveChanges:=True ' Save and Close Workbook
DoEvents ' yield processing time to other events
For i = LBound(myarray1) To UBound(myarray1)
Debug.Print myarray1(i, 1)
Next
myFile = Dir ' Get next file name
Loop
' MsgBox "Task Complete!"
End If
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
I'm looking to select a directory and then loop through each xlsm file within that directory. For each loop it should open the file, copy a range and paste into the current workbook under a specific sheet.
I.e. the first file will paste into sheet1 the second opened file will past into sheet 2, and so on.
I have some code, now I need help to get it to paste the rang into a sheets.count? or something like that. At the moment it just pastes into sheet 1 because that is static.
Sub Test()
Dim wb As Workbook, wb1 As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
Set wb1 = Workbooks(ThisWorkbook.Name)
Application.ScreenUpdating = False
Application.EnableEvents = 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 = "*.xlsm"
'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)
'Loop through each Excel file in folder
Do While myFile <> ""
'Set variable equal to opened workbook
Set wb = Workbooks.Open(Filename:=myPath & myFile)
'Ensure Workbook has opened before moving on to next line of code
DoEvents
'Copy data from opened workbook
wb.Sheets("HI Sub-segment split").Range("A1:Z1").Copy
'Paste data into destination workbook
wb1.Sheet(1).Range("A1:Z1").PasteSpecial xlPasteValues
'Close Workbook
wb.Close
'Ensure Workbook has closed before moving on to next line of code
DoEvents
'Get next file name
myFile = Dir
Loop
'Message Box when tasks are completed
MsgBox "Import Complete!"
ResetSettings:
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Worked with this...
Sub Testing()
'
'
'
Dim wb As Workbook, wb1 As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
Dim loop_ctr As Integer
Set wb1 = Workbooks(ThisWorkbook.Name)
loop_ctr = 1
Application.ScreenUpdating = False
Application.EnableEvents = 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)
'Loop through each Excel file in folder
Do While myFile <> ""
'Set variable equal to opened workbook
Set wb = Workbooks.Open(Filename:=myPath & myFile)
'Ensure Workbook has opened before moving on to next line of code
DoEvents
'Copy data from opened workbook
wb.Sheets("Sheet1").Range("A1:B2").Copy
'Paste data into destination workbook
wb1.Sheets(loop_ctr).Range("A1:B2").PasteSpecial xlPasteValues
'Close Workbook
wb.Close
'Ensure Workbook has closed before moving on to next line of code
DoEvents
'Get next file name
myFile = Dir
'Update loop_ctr value
loop_ctr = loop_ctr + 1
Loop
'Message Box when tasks are completed
MsgBox "Import Complete!"
ResetSettings:
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Whenever I run this code I get: Run-time error '9' Subscript out of range. Can't figure out how to fix this error, please help.
The code runs trough excel files in a selected folder and copy pastes the selected row.
In the next step I would like to extend the code, to store and sum each cell value like this:
var1 = var1 + range("A5").value
But first please help me how to fix this error. Thank you.
Sub LoopAllExcelFilesInFolder()
Dim OutputWs As Worksheet
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
Dim Lastrow As Long
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = 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
myExtension = "*.xlsx"
'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)
'set output worksheet
OutputWs = ThisWorkbook.Worksheets(Test)
'Loop through each Excel file in folder
Do While myFile <> ""
Workbooks.Open (myPath & myFile)
Range("A1:D3").Copy
ActiveWorkbook.Close
Lastrow = OutputWs.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Paste Destination:=Worksheets("Test").Range(Cells(Lastrow, 1), Cells(Lastrow, 4))
'Get next file name
myFile = Dir()
Loop
'Message Box when tasks are completed
MsgBox "Task Complete!"
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
To set an object reference to your worksheet, you need the keyword Set included:
Set OutputWs = ThisWorkbook.Worksheets("yoursheetname")
The get next file name should also be myFile = Dir and not include the parenthesis.
I took a closer look at the code and it appears that you're not explicitly defining which books are which in each case, meaning that the "orphaned" range statements can cause you problems. The 1004 error though is coming from your Paste statement, which I have corrected for you in the following code:
Sub LoopAllExcelFilesInFolder()
Dim OutputWs As Worksheet
Dim oNewBook As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
Dim Lastrow As Long
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = 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
myExtension = "*.xlsx"
'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)
'set output worksheet
Set OutputWs = ThisWorkbook.Worksheets("Test")
'Loop through each Excel file in folder
Do While myFile <> ""
Set oNewBook = Workbooks.Open(myPath & myFile)
oNewBook.Worksheets(1).Range("A1:D3").Copy
oNewBook.Close
Lastrow = OutputWs.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
With OutputWs
Lastrow = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Row
OutputWs.Paste .Range("A" & Lastrow & ":" & "D" & Lastrow)
End With
'Get next file name
myFile = Dir
Loop
'Message Box when tasks are completed
MsgBox "Task Complete!"
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Note that this code assumes that you want to copy from the first worksheet of the opened workbook (hence the oNewBook.Worksheets(1) added to the Range.Copy statement)
My code runs trough dozens of excel documents, selects range and gives the range to an array. I would like to add up the arrays to get a summarized data then paste the result to an existing worksheet.
The formula should be something like this:
rangeVar = oNewBook.Worksheets(1).Range("A1:D4").Value
sumRange = sumRange + rangeVar
Important! Some cells in the range is empty (I don't know is this matters). Also I would like to add up the values separately like sumRange(1,1)+rangeVar(1,1) ; sumRange(2,2)+rangeVar(2,2) , etc... How to do this?
You can check the code here:
Sub LoopAllExcelFilesInFolder()
Dim OutputWs As Worksheet
Dim oNewBook As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
Dim Lastrow As Long
Dim i As Integer, j As Integer
Dim summaryVar() As Variant
Dim rangeVar() As Variant
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = 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
myExtension = "*.xlsx"
'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)
'set output worksheet
Set OutputWs = ThisWorkbook.Worksheets("Teszt")
'Loop through each Excel file in folder
Do While myFile <> ""
Set oNewBook = Workbooks.Open(myPath & myFile)
rangeVar = oNewBook.Worksheets(1).Range("A1:D4").Value
oNewBook.Close
'Copy selected items
With OutputWs
Lastrow = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Row
OutputWs.Range("A" & Lastrow & ":" & "D" & Lastrow) = Application.WorksheetFunction.Sum(rangeVar) 'summaryVar
Paste:=xlPasteAll, operation:=xlPasteSpecialOperationAdd, skipBlanks:=False
Application.CutCopyMode = False
End With
'Get next file name
myFile = Dir
Loop
'Message Box when tasks are completed
MsgBox "Task Complete!"
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
S. Meaden answers this question wonderfully in How to add arrays?. Instead of trying to add the two arrays together, he makes use of Excel's pasteSpecial Addvalues function to add the original range's values to another range. Based on his code, something like the below should work.
Set tempWS = Sheets.Add
Do While myFile <> ""
Set oNewBook = Workbooks.Open(myPath & myFile)
oNewBook.Worksheets(1).Range("A1:D4").Copy
tempWS.Range("A1:D4").PasteSpecial Paste:=xlPasteAll, operation:=xlPasteSpecialOperationAdd
oNewBook.Close
Standard Excel Worksheet Functions will work on 1 and 2 dimensional arras.
Sub Test()
Dim array2(25, 25) As Double
Dim i As Integer, j As Integer
For i = 0 To UBound(array2, 1)
For j = 0 To UBound(array2, 1)
array2(i, j) = Int((Rnd * 100) + 1)
Next
Next
MsgBox WorksheetFunction.Sum(array2)
End Sub
I am using a code to loop through all files in a user specified folder and perform a task.
The codes begins executing and then unexpectedly aborts. The first attempt aborted after about 40 files. The second attempt went as far as 177 files. Upon aborting the results to that point are appearing and are accurate.
Does anyone have any idea as to why it may be aborting and/or a different solution. the destination folder has about 7000 files needing data extracted. See existing code below.
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
I've taken your code and tightened it up by removing all of the workbook.activate commands. Likewise, I've used direct value transfer in place of the clipboard's copy & paste special, values.
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
I don't know if that will save enough resource to finish off your long task but it should make some improvements.