Hi everyone,
I am very new to VBA. I have 261 files in a directory that need formatting. I have a loop macro to do this and it seems to work with out issue. However, it is very clunky and I ran a test on 261 files locally that took about 2 hours. The real deal will be on a server. I scabbed this together using the record function and various forum threads.
Does anyone have any advice on how to stream line this macro?
I am very new to VBA. I have 261 files in a directory that need formatting. I have a loop macro to do this and it seems to work with out issue. However, it is very clunky and I ran a test on 261 files locally that took about 2 hours. The real deal will be on a server. I scabbed this together using the record function and various forum threads.
Does anyone have any advice on how to stream line this macro?
VBA Code:
Sub AllWorkbooksInSelectedDirectory()
'
'
'
'This macro will consolidate all the IRMC output data into a single worksheet and slightly format the
'original worksheets, then save at the original file path. It will then repeat itself for each workbook in a directory.
'
'
'The user selects the directory. ********BEWARE, IF THERE ARE MANY FILES WITHIN A DIRECTORY IT WILL TAKE A WHILE********
'
'
'
'Path collected from the folder picker dialog
Dim MyFolder As String
'Filename obtained by DIR function
Dim MyFile As String
'Used to loop through each workbook
Dim wbk As Workbook
On Error Resume Next
Application.ScreenUpdating = False
'Opens the folder picker dialog to allow user selection
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "SELECT FOLDER"
.ButtonName = "RUN"
.InitialFileName = "\\nw\data\787FlexTrack\Data\Final-Body-Join\30-IRMC_Extractions\"
.Show
.AllowMultiSelect = False
'If no folder is selected, abort
If .SelectedItems.Count = 0 Then
MsgBox "You did not select a folder"
Exit Sub
End If
'Assign selected folder to MyFolder
MyFolder = .SelectedItems(1) & "\"
End With
'DIR gets the first file of the folder
MyFile = Dir(MyFolder)
'Loop through all files in a folder until DIR cannot find anymore
Do While MyFile <> ""
'Opens the file and assigns to the wbk variable for future use
Set wbk = Workbooks.Open(Filename:=MyFolder & MyFile)
'Replace the line below with the statements you would want your macro to perform
'Begin of original non-loop code
'Remove when updating master loop
'Creates Header
Sheets.Add Before:=Sheets(1)
ActiveCell.FormulaR1C1 = "SOURCE_IRM"
Range("B1").Select
ActiveCell.FormulaR1C1 = "GEOMETRICAL_SET"
Range("C1").Select
ActiveCell.FormulaR1C1 = "POINT_NAME"
Range("D1").Select
ActiveCell.FormulaR1C1 = "STANDARD_PART_01"
Range("E1").Select
ActiveCell.FormulaR1C1 = "STANDARD_PART_02"
Range("D1:E1").Select
Selection.AutoFill Destination:=Range("D1:K1"), Type:=xlFillDefault
Range("L1").Select
ActiveCell.FormulaR1C1 = "X-COORD"
Range("M1").Select
ActiveCell.FormulaR1C1 = "Y-COORD"
Range("N1").Select
ActiveCell.FormulaR1C1 = "Z-COORD"
Range("O1").Select
ActiveCell.FormulaR1C1 = "PARAMETER_NAME"
Range("P1").Select
ActiveCell.FormulaR1C1 = "PARAMETER_VALUE"
Range("Q1").Select
ActiveCell.FormulaR1C1 = "FL_NUMBER"
Range("R1").Select
ActiveCell.FormulaR1C1 = "FL_TEXT_NOTE_NUMBER"
Range("S1").Select
ActiveCell.FormulaR1C1 = "FLAG_NOTE"
Range("A1:S1").Select
Selection.Font.Bold = True
Range("A2").Select
'Remove when updating master loop
'Copy/Paste Data on IRMC Tab (Sheet(1))
'Copy JDs and Point coords
Sheets(2).Select
If Sheets(2).Range("C2") Like "*Def*" Then
Range("C2:O2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
'Paste JDs and Point coords
Sheets(1).Select
Range("B2").Select
ActiveSheet.Paste
End If
'Copy/Paste Data on Parameters Tab (Sheet(3))
'Copy Column A2:A
Sheets(3).Select
If Sheets(3).Range("A2") Like "*Def*" Or Sheets(3).Range("A2") Like "*Note*" Then
Range("A2").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
'Pastes Column A2:A
Sheets(1).Select
Range("B2").Select
Range("B" & Rows.Count).End(xlUp).Offset(1).Select
ActiveSheet.Paste
'Copy Columns C2:D2
Sheets(3).Select
Range("B2").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
'Pastes Columns C2:D2
Sheets(1).Select
Range("N" & Rows.Count).End(xlUp).Offset(1, 1).Select
ActiveSheet.Paste
End If
'Copy/Paste Data on TextNotes Tab (Sheet(4))
'Create and Copy Column A1:A
Sheets(4).Select
If Sheets(4).Range("C1") Like "*FL*" Then
Range("A1").Select
ActiveCell.FormulaR1C1 = "Text Notes"
Selection.AutoFill Destination:=Range("A1:A" & Range("B" & Rows.Count).End(xlUp).Row)
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
'Paste Column A1:A
Sheets(1).Select
Range("B2").Select
Range("B" & Rows.Count).End(xlUp).Offset(1).Select
ActiveSheet.Paste
'Copy Column C1:E1
Sheets(4).Select
Range("C1").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
'Pastes Text Notes to Sheet 1
Sheets(1).Select
Range("B2").Select
Range("P" & Rows.Count).End(xlUp).Offset(1, 1).Select
ActiveSheet.Paste
End If
'Sheet(2) sheet name pasted to cell A2
Sheets(2).Select
Range("A2").Select
ActiveSheet.[A2] = ActiveSheet.Name
'Copies sheet(2) A2
Application.CutCopyMode = False
ActiveCell.Copy
'Pastes sheet(1) A2
Sheets(1).Select
Range("A2").Select
ActiveSheet.Paste
'Auto Fills Column A based on the extent of Column B
Sheets(1).Select
Range("A2").Select
Selection.AutoFill Destination:=Range("A2:A" & Range("B" & Rows.Count).End(xlUp).Row)
Range(Selection, Selection.End(xlDown)).Select
'Remove IRMC_ from sheet (1) column A1:A
Columns("A:A").Select
Selection.Replace What:="IRMC ", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
'Auto Expand Columns A-P
Sheets(1).Select
Range("A1").Select
Columns("A:O").EntireColumn.AutoFit
Columns("Q:R").EntireColumn.AutoFit
Columns("P").columnwidth = 50
Columns("S").columnwidth = 50
'Clears any formatting below first row on sheet(1)
Sheets(1).Select
ActiveSheet.Range("A2:S2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearFormats
Range("A1").Select
'Renames sheet
Sheets(1).Select
ActiveSheet.Name = Range("A2")
'Clears A2, Sheet 2
Sheets(2).Select
Range("A2").Clear
Range("A1").Select
ActiveSheet.Name = "IRMC JDs Parts & Points"
Range("A1").Select
'Renames Sheet 3
Sheets(3).Select
Range("A1").Select
ActiveSheet.Name = "IRMC Parameters"
Range("A1").Select
'Renames Sheet 4 to include IRMC
Sheets(4).Select
Range("A1").Select
ActiveSheet.Name = "IRMC TextNotes"
Columns("A:E").EntireColumn.AutoFit
Range("A1").Select
'Activates Sheet 1 for sorting
Sheets(1).Select
Range("A1").Select
With ActiveSheet.Sort
'.SortFields.Add Key:=Range("A1"), Order:=xlAscending
.SortFields.Add Key:=Range("B1"), Order:=xlAscending
.SortFields.Add Key:=Range("O1"), Order:=xlAscending
'.SortFields.Add Key:=Range("P1"), Order:=xlAscending
.SetRange Range("B1", Range("P" & Rows.Count).End(xlUp).Offset(1))
.Header = xlYes
.Apply
End With
'Prevents selectable dialogues from popping up
Application.DisplayAlerts = False
Sheets(1).Select
Range("A1").Select
'End of original non-loop code
wbk.Close savechanges:=True
'DIR gets the next file in the folder
MyFile = Dir
Loop
Application.ScreenUpdating = True
End Sub