Advertisement
Guest User

Untitled

a guest
Jun 25th, 2019
73
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
text 2.41 KB | None | 0 0
  1. Sub LoopAllExcelFilesInFolder()
  2.  
  3. Dim wb As Workbook
  4. Dim myPath As String
  5. Dim myFile As String
  6. Dim myExtension As String
  7. Dim FldrPicker As FileDialog
  8.  
  9. 'Optimize Macro Speed
  10. Application.ScreenUpdating = False
  11. Application.EnableEvents = False
  12. Application.Calculation = xlCalculationManual
  13. ActiveWorkbook.CheckCompatibility = False
  14. Application.AskToUpdateLinks = False
  15. Application.DisplayAlerts = False
  16.  
  17. 'Retrieve Target Folder Path From User
  18. Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
  19.  
  20. With FldrPicker
  21. .Title = "Select A Target Folder"
  22. .AllowMultiSelect = False
  23. If .Show <> -1 Then GoTo NextCode
  24. myPath = .SelectedItems(1) & ""
  25. End With
  26.  
  27. 'In Case of Cancel
  28. NextCode:
  29. myPath = myPath
  30. If myPath = "" Then GoTo ResetSettings
  31.  
  32. 'Target File Extension (must include wildcard "*")
  33. myExtension = "*.xls*"
  34.  
  35. 'Target Path with Ending Extention
  36. myFile = Dir(myPath & myExtension)
  37.  
  38. 'Loop through each Excel file in folder
  39. Do While myFile <> ""
  40. 'Set variable equal to opened workbook
  41. Set wb = Workbooks.Open(Filename:=myPath & myFile)
  42.  
  43. 'Ensure Workbook has opened before moving on to next line of code
  44. DoEvents
  45.  
  46. 'If DataEntry is the active ws, then change to the next worksheet
  47. If ActiveSheet.Name = "DataEntry" Then
  48. ActiveSheet.Next.Activate
  49. End If
  50.  
  51. 'Insert a Column of Worksheet names
  52. Columns(1).Insert
  53. For i = 1 To Sheets.Count
  54. Cells(i, 1) = Sheets(i).Name
  55. Next i
  56.  
  57. 'Selects then Copy/Paste into SCD list
  58. If Cells(2, 1).Value = "" Then
  59. Cells(1, 1).Select
  60. Selection.Copy
  61. Else:
  62. Range(Range("A1"), Range("A1").End(xlDown)).Select
  63. Selection.Copy
  64. End If
  65.  
  66. Windows("SCD List.xlsm").Activate
  67.  
  68. 'Paste into SCD List
  69. If Cells(1, 1).Value = "" Then
  70. Cells(1, 1).Select
  71. Else:
  72. Range("A1").End(xlDown).Offset(1, 0).Select
  73. End If
  74. ActiveSheet.Paste
  75.  
  76. 'Closes Workbook without copying
  77. wb.Close SaveChanges:=False
  78.  
  79. 'Ensure Workbook has closed before moving on to next line of code
  80. DoEvents
  81.  
  82. 'Get next file name
  83. myFile = Dir
  84. Loop
  85.  
  86. 'Message Box when tasks are completed
  87. MsgBox "Task Complete!"
  88.  
  89. ResetSettings:
  90. 'Reset Macro Optimization Settings
  91. Application.EnableEvents = True
  92. Application.Calculation = xlCalculationAutomatic
  93. Application.ScreenUpdating = True
  94.  
  95. End Sub
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement