Formatting Efficiency

J

JustinJ

New Member
Joined
Sep 19, 2020
Messages
16
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
 

Excel Facts

Which lookup functions find a value equal or greater than the lookup value?
MATCH uses -1 to find larger value (lookup table must be sorted ZA). XLOOKUP uses 1 to find values greater and does not need to be sorted.
Sort by date Sort by votes
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
 
Upvote 0
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?
 
Upvote 0
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
 
Upvote 0
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!!!
 
Upvote 0
DanteAmor said:
Im glad to help you. Thanks for the feedback.
Click to expand...

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
 
Upvote 0
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
 
Upvote 0
DanteAmor said:
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
Click to expand...


Worked perfectly, thanks for your help!
 
Upvote 0
You must log in or register to reply here.

Similar threads

N
  • Question
VBA Questions - Copying dynamic data from one tab to another and deleting filtered rows
Replies
1
Views
187
DanteAmor
DanteAmor
L
  • Question
Variable Rows, Help Speeding Up
Replies
4
Views
318
kevin9999
K
P
  • Question
Help with Vba Code
Replies
3
Views
161
Coyotex3
C
L
  • Solved
VBA remove leading zeros
2
Replies
14
Views
976
Joe4
Joe4
T
  • Question
ActiveSheet. Paste error
Replies
1
Views
39
RoryA
RoryA

Forum statistics

Threads
1,215,038
Messages
6,122,798
Members
449,095
Latest member
m_smith_solihull

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top