Formatting Efficiency

JustinJ

New Member
Joined
Sep 19, 2020
Messages
14
Office Version
  1. 2013
Platform
  1. Windows
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?

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
 

Some videos you may like

Excel Facts

Bring active cell back into view
Start at A1 and select to A9999 while writing a formula, you can't see A1 anymore. Press Ctrl+Backspace to bring active cell into view.

yky

Well-known Member
Joined
Jun 7, 2011
Messages
1,755
Office Version
  1. 2010
Platform
  1. Windows
Set calculation to manual in the beginning of the code and set it back to automatic at the end using the following code:

VBA Code:
Application.Calculation = xlCalculationManual 
...
...
...
    Application.Calculation = xlCalculationAutomatic
 

JustinJ

New Member
Joined
Sep 19, 2020
Messages
14
Office Version
  1. 2013
Platform
  1. Windows
Thanks for the tip!

I compared the time stamps to my previous trial run and it seems to be operating at the same rhythm.

Is the additional script you're suggesting for formulas?
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,593
Office Version
  1. 2007
Platform
  1. Windows
Hi, I rewrote all the code to not Select every sheet, so as not to copy paste every range.
Now it only passes values from one sheet to another, this is faster.
You will have to test all the code, maybe I miss something (had to redo it). Also check the speed.

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********
'
  Dim MyFolder As String  'Path collected from the folder picker dialog
  Dim MyFile As String    'Filename obtained by DIR function
  Dim wbk As Workbook     'Used to loop through each workbook
  Dim sh1 As Worksheet
  Dim lr As Long
  
  With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .Calculation = xlCalculationManual
    .DisplayAlerts = False
  End With
  '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 .SelectedItems.Count = 0 Then
      MsgBox "You did not select a folder"
      Exit Sub                              'If no folder is selected, abort
    End If
    MyFolder = .SelectedItems(1) & "\"      'Assign selected folder to MyFolder
  End With
  MyFile = Dir(MyFolder & "*.xls*")         'DIR gets the first file of the folder

  'Loop through all files in a folder until DIR cannot find anymore
  Do While MyFile <> ""
    Set wbk = Workbooks.Open(Filename:=MyFolder & MyFile) 'Opens the file and assigns to wbk
    Sheets.Add Before:=Sheets(1)
    Set sh1 = ActiveSheet

    With sh1.Range("A1:S1")     'Creates Header
      .Value = Array("SOURCE_IRM", "GEOMETRICAL_SET", "POINT_NAME", _
        "STANDARD_PART_01", "STANDARD_PART_02", "STANDARD_PART_03", "STANDARD_PART_04", _
        "STANDARD_PART_05", "STANDARD_PART_06", "STANDARD_PART_07", "STANDARD_PART_08", _
        "X-COORD", "Y-COORD", "Z-COORD", "PARAMETER_NAME", "PARAMETER_VALUE", _
        "FL_NUMBER", "FL_TEXT_NOTE_NUMBER", "FLAG_NOTE")
      .Font.Bold = True
    End With
    
    With Sheets(2)      'Copy/Paste Data on IRMC Tab (Sheet(2))
      If .Range("C2") Like "*Def*" Then
        lr = .Range("C" & Rows.Count).End(3).Row
        sh1.Range("B2").Resize(lr - 1, 13).Value = .Range("C2:O" & lr).Value
      End If
      .Name = "IRMC JDs Parts & Points"
      sh1.Range("A2") = .Name
    End With
    
    With Sheets(3)      'Copy/Paste Data on Parameters Tab (Sheet(3))
      If .Range("A2") Like "*Def*" Or Sheets(3).Range("A2") Like "*Note*" Then
        lr = .Range("A" & Rows.Count).End(3).Row
        sh1.Range("B" & Rows.Count).End(3)(2).Resize(lr - 1, 1).Value = .Range("A2:A" & lr).Value
        lr = .Range("B" & Rows.Count).End(3).Row
        sh1.Range("N" & Rows.Count).End(3).Offset(1, 1).Resize(lr - 1, 2).Value = .Range("B2:C" & lr).Value
      End If
      .Name = "IRMC Parameters"
    End With
    
    With Sheets(4)      'Copy/Paste Data on TextNotes Tab (Sheet(4))
      If .Range("C1") Like "*FL*" Then
        lr = .Range("B" & Rows.Count).End(3).Row
        .Range("A1:A" & lr).Value = "Text Notes"
        sh1.Range("B" & Rows.Count).End(3).Offset(1).Resize(lr, 1) = "Text Notes"
        lr = .Range("C" & Rows.Count).End(3).Row
        sh1.Range("P" & Rows.Count).End(3).Offset(1, 1).Resize(lr, 3).Value = .Range("C1:E" & lr).Value
      End If
      .Name = "IRMC TextNotes"
      .Columns("A:E").EntireColumn.AutoFit
    End With
    
    sh1.Range("A2:A" & sh1.Range("B" & Rows.Count).End(3).Row).Value = sh1.Range("A2").Value  'Auto Fills Column A
    sh1.Range("A:A").Replace "IRMC ", "", xlPart, xlByRows, False   'Remove IRMC_ from sheet (1) column A1:A
    sh1.Range("A:R").EntireColumn.AutoFit                           'Auto Expand Columns A-P
    sh1.Range("P:P, S:S").ColumnWidth = 50
    sh1.Range("B1:P" & sh1.Range("A" & Rows.Count).End(3).Row).Sort sh1.[B1], 1, sh1.[O1], , 1, Header:=xlYes
    wbk.Close savechanges:=True
    MyFile = Dir                                                     'DIR gets the next file in the folder
  Loop
  
  With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
    .DisplayAlerts = True
  End With
End Sub
 

JustinJ

New Member
Joined
Sep 19, 2020
Messages
14
Office Version
  1. 2013
Platform
  1. Windows

ADVERTISEMENT

Lightning quick on the local trial!
Couple things to rearrange but I think I can manage from here.

It is one thing to be able to create an output with known data source, but with unknown source.... Very impressive!
Thanks a million!!!
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,593
Office Version
  1. 2007
Platform
  1. Windows
Im glad to help you. Thanks for the feedback.
 

JustinJ

New Member
Joined
Sep 19, 2020
Messages
14
Office Version
  1. 2013
Platform
  1. Windows

ADVERTISEMENT

Im glad to help you. Thanks for the feedback.

Hi DanteAmor,
My additions are at lines 54 and line 56.

I am running into another issue now. During larger sample testing I have found that some sheets may be missing. I believe this can only happen on sheet 4 as it does not get headers like sheets 2-3. Is there a way to 'IF' the 'With Sheets(4)' lines?

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********
'
  Dim MyFolder As String  'Path collected from the folder picker dialog
  Dim MyFile As String    'Filename obtained by DIR function
  Dim wbk As Workbook     'Used to loop through each workbook
  Dim sh1 As Worksheet
  Dim lr As Long
 
  With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .Calculation = xlCalculationManual
    .DisplayAlerts = False
  End With
  '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\"
    .InitialFileName = "C:\Users\nc541c\Desktop\IRMC Extraction Test\BATCH\From Blade\Active\"
    .Show
    .AllowMultiSelect = False
    If .SelectedItems.Count = 0 Then
      MsgBox "You did not select a folder"
      Exit Sub                              'If no folder is selected, abort
    End If
    MyFolder = .SelectedItems(1) & "\"      'Assign selected folder to MyFolder
  End With
  MyFile = Dir(MyFolder & "*.xls*")         'DIR gets the first file of the folder

  'Loop through all files in a folder until DIR cannot find anymore
  Do While MyFile <> ""
    Set wbk = Workbooks.Open(Filename:=MyFolder & MyFile) 'Opens the file and assigns to wbk
    Sheets.Add BEFORE:=Sheets(1)
    Set sh1 = ActiveSheet

    With sh1.Range("A1:S1")     'Creates Header
      .Value = Array("SOURCE_IRM", "GEOMETRICAL_SET", "POINT_NAME", _
        "STANDARD_PART_01", "STANDARD_PART_02", "STANDARD_PART_03", "STANDARD_PART_04", _
        "STANDARD_PART_05", "STANDARD_PART_06", "STANDARD_PART_07", "STANDARD_PART_08", _
        "X-COORD", "Y-COORD", "Z-COORD", "PARAMETER_NAME", "PARAMETER_VALUE", _
        "FL_NUMBER", "FL_TEXT_NOTE_NUMBER", "FLAG_NOTE")
      .Font.Bold = True
    End With
    
    With Sheets(2)      'Copy/Paste Data on IRMC Tab (Sheet(2))
      If .Range("C2") Like "*Def*" Then
        lr = .Range("C" & Rows.Count).End(3).Row
        sh1.Range("B2").Resize(lr - 1, 13).Value = .Range("C2:O" & lr).Value
      End If
      sh1.Range("A2") = .Name '<-----------------------------------------------------------NEW TAKE SHEET 2 NAME AND INSERT SHEET 1, A2
      .Name = "IRMC JDs Parts & Points"
      sh1.Name = Range("A2") '<-----------------------------------------------------------NEW TAKE SHEET 1, A2 AND INSERT AS SHEET 1 NAME
    End With
    
    With Sheets(3)      'Copy/Paste Data on Parameters Tab (Sheet(3))
      If .Range("A2") Like "*Def*" Or Sheets(3).Range("A2") Like "*Note*" Then
        lr = .Range("A" & Rows.Count).End(3).Row
        sh1.Range("B" & Rows.Count).End(3)(2).Resize(lr - 1, 1).Value = .Range("A2:A" & lr).Value
        lr = .Range("B" & Rows.Count).End(3).Row
        sh1.Range("N" & Rows.Count).End(3).Offset(1, 1).Resize(lr - 1, 2).Value = .Range("B2:C" & lr).Value
      End If
      .Name = "IRMC Parameters"
    End With
    
    With Sheets(4)      'Copy/Paste Data on TextNotes Tab (Sheet(4))
      If .Range("C1") Like "*FL*" Then
        lr = .Range("B" & Rows.Count).End(3).Row
        .Range("A1:A" & lr).Value = "Text Notes"
        sh1.Range("B" & Rows.Count).End(3).Offset(1).Resize(lr, 1) = "Text Notes"
        lr = .Range("C" & Rows.Count).End(3).Row
        sh1.Range("P" & Rows.Count).End(3).Offset(1, 1).Resize(lr, 3).Value = .Range("C1:E" & lr).Value
      End If
      .Name = "IRMC TextNotes"
      .Columns("A:E").EntireColumn.AutoFit
    End With
    
    sh1.Range("A2:A" & sh1.Range("B" & Rows.Count).End(3).Row).Value = sh1.Range("A2").Value  'Auto Fills Column A
    sh1.Range("A:A").Replace "IRMC ", "", xlPart, xlByRows, False   'Remove IRMC_ from sheet (1) column A1:A
    sh1.Range("A:R").EntireColumn.AutoFit                           'Auto Expand Columns A-P
    sh1.Range("P:P, S:S").columnwidth = 50
    sh1.Range("B1:P" & sh1.Range("A" & Rows.Count).End(3).Row).Sort sh1.[B1], 1, sh1.[O1], , 1, Header:=xlYes
    wbk.Close savechanges:=True
    MyFile = Dir                                                     'DIR gets the next file in the folder
  Loop
 
  With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
    .DisplayAlerts = True
  End With
End Sub
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,593
Office Version
  1. 2007
Platform
  1. Windows
Try this:

Rich (BB 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********
'
  Dim MyFolder As String  'Path collected from the folder picker dialog
  Dim MyFile As String    'Filename obtained by DIR function
  Dim wbk As Workbook     'Used to loop through each workbook
  Dim sh1 As Worksheet
  Dim lr As Long
 
  With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .Calculation = xlCalculationManual
    .DisplayAlerts = False
  End With
  '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\"
    .InitialFileName = "C:\Users\nc541c\Desktop\IRMC Extraction Test\BATCH\From Blade\Active\"
    .Show
    .AllowMultiSelect = False
    If .SelectedItems.Count = 0 Then
      MsgBox "You did not select a folder"
      Exit Sub                              'If no folder is selected, abort
    End If
    MyFolder = .SelectedItems(1) & "\"      'Assign selected folder to MyFolder
  End With
  MyFile = Dir(MyFolder & "*.xls*")         'DIR gets the first file of the folder

  'Loop through all files in a folder until DIR cannot find anymore
  Do While MyFile <> ""
    Set wbk = Workbooks.Open(Filename:=MyFolder & MyFile) 'Opens the file and assigns to wbk
    Sheets.Add BEFORE:=Sheets(1)
    Set sh1 = ActiveSheet

    With sh1.Range("A1:S1")     'Creates Header
      .Value = Array("SOURCE_IRM", "GEOMETRICAL_SET", "POINT_NAME", _
        "STANDARD_PART_01", "STANDARD_PART_02", "STANDARD_PART_03", "STANDARD_PART_04", _
        "STANDARD_PART_05", "STANDARD_PART_06", "STANDARD_PART_07", "STANDARD_PART_08", _
        "X-COORD", "Y-COORD", "Z-COORD", "PARAMETER_NAME", "PARAMETER_VALUE", _
        "FL_NUMBER", "FL_TEXT_NOTE_NUMBER", "FLAG_NOTE")
      .Font.Bold = True
    End With
    
    With Sheets(2)      'Copy/Paste Data on IRMC Tab (Sheet(2))
      If .Range("C2") Like "*Def*" Then
        lr = .Range("C" & Rows.Count).End(3).Row
        sh1.Range("B2").Resize(lr - 1, 13).Value = .Range("C2:O" & lr).Value
      End If
      sh1.Range("A2") = .Name '<-----------------------------------------------------------NEW TAKE SHEET 2 NAME AND INSERT SHEET 1, A2
      .Name = "IRMC JDs Parts & Points"
      sh1.Name = Range("A2") '<-----------------------------------------------------------NEW TAKE SHEET 1, A2 AND INSERT AS SHEET 1 NAME
    End With
    
    With Sheets(3)      'Copy/Paste Data on Parameters Tab (Sheet(3))
      If .Range("A2") Like "*Def*" Or Sheets(3).Range("A2") Like "*Note*" Then
        lr = .Range("A" & Rows.Count).End(3).Row
        sh1.Range("B" & Rows.Count).End(3)(2).Resize(lr - 1, 1).Value = .Range("A2:A" & lr).Value
        lr = .Range("B" & Rows.Count).End(3).Row
        sh1.Range("N" & Rows.Count).End(3).Offset(1, 1).Resize(lr - 1, 2).Value = .Range("B2:C" & lr).Value
      End If
      .Name = "IRMC Parameters"
    End With
    
if sheets.count = 4 then
    With Sheets(4)      'Copy/Paste Data on TextNotes Tab (Sheet(4))
      If .Range("C1") Like "*FL*" Then
        lr = .Range("B" & Rows.Count).End(3).Row
        .Range("A1:A" & lr).Value = "Text Notes"
        sh1.Range("B" & Rows.Count).End(3).Offset(1).Resize(lr, 1) = "Text Notes"
        lr = .Range("C" & Rows.Count).End(3).Row
        sh1.Range("P" & Rows.Count).End(3).Offset(1, 1).Resize(lr, 3).Value = .Range("C1:E" & lr).Value
      End If
      .Name = "IRMC TextNotes"
      .Columns("A:E").EntireColumn.AutoFit
    End With
end if

    sh1.Range("A2:A" & sh1.Range("B" & Rows.Count).End(3).Row).Value = sh1.Range("A2").Value  'Auto Fills Column A
    sh1.Range("A:A").Replace "IRMC ", "", xlPart, xlByRows, False   'Remove IRMC_ from sheet (1) column A1:A
    sh1.Range("A:R").EntireColumn.AutoFit                           'Auto Expand Columns A-P
    sh1.Range("P:P, S:S").columnwidth = 50
    sh1.Range("B1:P" & sh1.Range("A" & Rows.Count).End(3).Row).Sort sh1.[B1], 1, sh1.[O1], , 1, Header:=xlYes
    wbk.Close savechanges:=True
    MyFile = Dir                                                     'DIR gets the next file in the folder
  Loop
 
  With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
    .DisplayAlerts = True
  End With
End Sub
 

JustinJ

New Member
Joined
Sep 19, 2020
Messages
14
Office Version
  1. 2013
Platform
  1. Windows
Try this:

Rich (BB 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********
'
  Dim MyFolder As String  'Path collected from the folder picker dialog
  Dim MyFile As String    'Filename obtained by DIR function
  Dim wbk As Workbook     'Used to loop through each workbook
  Dim sh1 As Worksheet
  Dim lr As Long

  With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .Calculation = xlCalculationManual
    .DisplayAlerts = False
  End With
  '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\"
    .InitialFileName = "C:\Users\nc541c\Desktop\IRMC Extraction Test\BATCH\From Blade\Active\"
    .Show
    .AllowMultiSelect = False
    If .SelectedItems.Count = 0 Then
      MsgBox "You did not select a folder"
      Exit Sub                              'If no folder is selected, abort
    End If
    MyFolder = .SelectedItems(1) & "\"      'Assign selected folder to MyFolder
  End With
  MyFile = Dir(MyFolder & "*.xls*")         'DIR gets the first file of the folder

  'Loop through all files in a folder until DIR cannot find anymore
  Do While MyFile <> ""
    Set wbk = Workbooks.Open(Filename:=MyFolder & MyFile) 'Opens the file and assigns to wbk
    Sheets.Add BEFORE:=Sheets(1)
    Set sh1 = ActiveSheet

    With sh1.Range("A1:S1")     'Creates Header
      .Value = Array("SOURCE_IRM", "GEOMETRICAL_SET", "POINT_NAME", _
        "STANDARD_PART_01", "STANDARD_PART_02", "STANDARD_PART_03", "STANDARD_PART_04", _
        "STANDARD_PART_05", "STANDARD_PART_06", "STANDARD_PART_07", "STANDARD_PART_08", _
        "X-COORD", "Y-COORD", "Z-COORD", "PARAMETER_NAME", "PARAMETER_VALUE", _
        "FL_NUMBER", "FL_TEXT_NOTE_NUMBER", "FLAG_NOTE")
      .Font.Bold = True
    End With
   
    With Sheets(2)      'Copy/Paste Data on IRMC Tab (Sheet(2))
      If .Range("C2") Like "*Def*" Then
        lr = .Range("C" & Rows.Count).End(3).Row
        sh1.Range("B2").Resize(lr - 1, 13).Value = .Range("C2:O" & lr).Value
      End If
      sh1.Range("A2") = .Name '<-----------------------------------------------------------NEW TAKE SHEET 2 NAME AND INSERT SHEET 1, A2
      .Name = "IRMC JDs Parts & Points"
      sh1.Name = Range("A2") '<-----------------------------------------------------------NEW TAKE SHEET 1, A2 AND INSERT AS SHEET 1 NAME
    End With
   
    With Sheets(3)      'Copy/Paste Data on Parameters Tab (Sheet(3))
      If .Range("A2") Like "*Def*" Or Sheets(3).Range("A2") Like "*Note*" Then
        lr = .Range("A" & Rows.Count).End(3).Row
        sh1.Range("B" & Rows.Count).End(3)(2).Resize(lr - 1, 1).Value = .Range("A2:A" & lr).Value
        lr = .Range("B" & Rows.Count).End(3).Row
        sh1.Range("N" & Rows.Count).End(3).Offset(1, 1).Resize(lr - 1, 2).Value = .Range("B2:C" & lr).Value
      End If
      .Name = "IRMC Parameters"
    End With
   
if sheets.count = 4 then
    With Sheets(4)      'Copy/Paste Data on TextNotes Tab (Sheet(4))
      If .Range("C1") Like "*FL*" Then
        lr = .Range("B" & Rows.Count).End(3).Row
        .Range("A1:A" & lr).Value = "Text Notes"
        sh1.Range("B" & Rows.Count).End(3).Offset(1).Resize(lr, 1) = "Text Notes"
        lr = .Range("C" & Rows.Count).End(3).Row
        sh1.Range("P" & Rows.Count).End(3).Offset(1, 1).Resize(lr, 3).Value = .Range("C1:E" & lr).Value
      End If
      .Name = "IRMC TextNotes"
      .Columns("A:E").EntireColumn.AutoFit
    End With
end if

    sh1.Range("A2:A" & sh1.Range("B" & Rows.Count).End(3).Row).Value = sh1.Range("A2").Value  'Auto Fills Column A
    sh1.Range("A:A").Replace "IRMC ", "", xlPart, xlByRows, False   'Remove IRMC_ from sheet (1) column A1:A
    sh1.Range("A:R").EntireColumn.AutoFit                           'Auto Expand Columns A-P
    sh1.Range("P:P, S:S").columnwidth = 50
    sh1.Range("B1:P" & sh1.Range("A" & Rows.Count).End(3).Row).Sort sh1.[B1], 1, sh1.[O1], , 1, Header:=xlYes
    wbk.Close savechanges:=True
    MyFile = Dir                                                     'DIR gets the next file in the folder
  Loop

  With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
    .DisplayAlerts = True
  End With
End Sub


Worked perfectly, thanks for your help!
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,593
Office Version
  1. 2007
Platform
  1. Windows
I'm glad to help you. Thanks for the feedback.
 

Watch MrExcel Video

Forum statistics

Threads
1,114,535
Messages
5,548,624
Members
410,858
Latest member
RamIndia
Top