Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- 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
- ActiveWorkbook.CheckCompatibility = False
- Application.AskToUpdateLinks = False
- Application.DisplayAlerts = False
- '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
- 'If DataEntry is the active ws, then change to the next worksheet
- If ActiveSheet.Name = "DataEntry" Then
- ActiveSheet.Next.Activate
- End If
- 'Insert a Column of Worksheet names
- Columns(1).Insert
- For i = 1 To Sheets.Count
- Cells(i, 1) = Sheets(i).Name
- Next i
- 'Selects then Copy/Paste into SCD list
- If Cells(2, 1).Value = "" Then
- Cells(1, 1).Select
- Selection.Copy
- Else:
- Range(Range("A1"), Range("A1").End(xlDown)).Select
- Selection.Copy
- End If
- Windows("SCD List.xlsm").Activate
- 'Paste into SCD List
- If Cells(1, 1).Value = "" Then
- Cells(1, 1).Select
- Else:
- Range("A1").End(xlDown).Offset(1, 0).Select
- End If
- ActiveSheet.Paste
- 'Closes Workbook without copying
- wb.Close SaveChanges:=False
- '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
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement