Hello all,
I am working on a code to find cycle times from three levels of folders and I have everything working but now I am trying to make things look better. I am trying to copy my results in a summary worksheet and use a template that is already open but I keep getting the run time error. I am not very experienced but I was curious if I am just labeling something wrong or missing something simple. The code is below
The error happens on the line "Sheets("Summary").Range("A1:A & LRowS). AdvanceFilter Action:=xlFiltercopy, CopyToRange:=Sheets("Summary").Range("B2"), Unique:=True
I am working on a code to find cycle times from three levels of folders and I have everything working but now I am trying to make things look better. I am trying to copy my results in a summary worksheet and use a template that is already open but I keep getting the run time error. I am not very experienced but I was curious if I am just labeling something wrong or missing something simple. The code is below
Code:
Option Explicit
Sub CycleTimeMacro() 'Begins the sub routine and allows for the macro to start on workbook opening
Dim FSO As Object 'Sets the dimension for File System Object to be used later
Dim fPath As String, DateFldr As String 'Sets the dimension for fpath to be used later
Dim SDate As Variant, EDate As Variant 'Sets the dimensions for dates
Dim LastRw As Long, LRowCurr As Long, LRowNew As Long, LRowS As Long, LRowR As Long, Col As Long, CL As Long, CS As Long 'Sets the dimensions for numbers
Dim LRowE As Long, LColE As Long
Dim FldrArrL2 As Variant, FldrArrL3 As Variant, myFolder As Variant, Sh As Variant, a As Variant, SumFldr As Variant 'Sets the dimensions for variants
Dim SumFile As Variant
Dim IsInArrL2 As Boolean, IsInArrL3 As Boolean 'Sets the dimensions for True or False variables
Dim NewB As Workbook, CurrFile As Workbook, MasterBook As Workbook, NewSmryB As Workbook, EBook As Workbook 'Sets the dimensions for workbooks
Dim Lvl1, Lvl2, Lvl3, myFile 'Sets the dimension for lvl1, my file, sub folder, and my subfolder to be used later
Set MasterBook = ThisWorkbook
On Error GoTo Canceled 'If the user selects cancel in the input box then the macro will stop
SDate = Application.InputBox(Prompt:="Choose the most recent date of the time period to process.", Type:=8).Value 'Prompts the user to select the start date, or most recent date, for the date range
EDate = Application.InputBox(Prompt:="Choose the end date of the time period to process.", Type:=8).Value 'Prompts the user to select the end date, oldest date, for the date range
If SDate = "" Then GoTo Canceled 'If the user selects an empty cell for start date then the macro will stop
If EDate = "" Then GoTo Canceled 'If the user selects an empty cell for end date then the macro will stop
On Error GoTo 0
Application.ScreenUpdating = False 'Turns off screen updating to speed up process time
DateFldr = "Cycle Time " & Format(Now, "DD-MM-YY hh.mm") 'Sets the name of the folder to be cycle time followed by date and time of the current day
MkDir "C:\Users\tnrhodges\Desktop\" & DateFldr 'Makes the directory for the new folder path, can be changed for different computer
Set FSO = CreateObject("Scripting.FileSystemObject") 'Sets the variable for the file system object
Set Lvl1 = FSO.GetFolder("C:\Users\tnrhodges\Desktop\2\") 'Sets level 1 as the "2" folder which contains all the folders to be processed, can be changed for different computers
If Err.Number <> 0 Then 'If there is an error turn screen updating back on and exit the sub
Application.ScreenUpdating = True
Exit Sub
End If
LastRw = Range("A" & Rows.Count).End(xlUp).Row + 1 'Sets the LastRw variable as all cells that contain data in the workbooks
For Each Lvl2 In Lvl1.subfolders 'Begins the loop to create the workbooks which are the level 2 folders
FldrArrL2 = Array("1", "2", "3", "4", "5", "6", "7", "8", "9", "A", "B") 'Creates an array for each of the line names, if more lines are added they can be included here
IsInArrL2 = Not IsError(Application.Match(Lvl2.Name, FldrArrL2, 0)) 'Creates an array to include all the level 2 folders that are not named in the above array
If IsInArrL2 = False Then GoTo NxtL2Fldr 'If the folder is in the second array the program will ignore it and continue to find one of interest
Set NewB = Workbooks.Add(1) 'Sets the new workbook variable as NewB
For Each Lvl3 In Lvl2.subfolders 'Begins the loop to create the worksheets which are the level 3 folders
FldrArrL3 = Array("A1", "I1", "M1", "M2", "M3", "M4", "M5", "P1", "Q1", _
"A2", "M1-lane1", "M1-lane2", "M2-lane1", "M2-lane2", "M3-lane1", _
"M3-lane2", "M4-lane1", "M4-lane2", "P1-lane1", "P1-lane2", "Q2") 'Creates an array for each of the machines, if more machines are added they can be included here
IsInArrL3 = Not IsError(Application.Match(Lvl3.Name, FldrArrL3, 0)) 'Creates an array for all the level 3 machines that are not included in the first array
If IsInArrL3 = False Then GoTo NxtL3Fldr 'If the folder is in the second array, such as the unloader, the program will ignore it and continue to the next
NewB.Sheets.Add(After:=Sheets(Sheets.Count)).Name = Lvl3.Name 'Creates a new sheet for each machine to be named as the level 3 name
Set myFolder = FSO.GetFolder(Lvl3).Files 'Sets the folder location to search for the level 3 files
For Each myFile In myFolder 'Begins the loop for each level 3 folder
If DateValue(myFile.datelastmodified) >= SDate And DateValue(myFile.datelastmodified) <= EDate Then 'Sets the date range to search for as the dates chosen at the beginning of the macro
Set CurrFile = Workbooks.Open(myFile) 'Sets the variable currfile as the open workbook
LRowCurr = CurrFile.Sheets(1).Range("D" & Rows.Count).End(xlUp).Row 'Sets the selection as range D onward from the daily file
NewB.Activate 'Activates the new workbook
LRowNew = NewB.Sheets(Lvl3.Name).Range("A" & Rows.Count).End(xlUp).Row + 1 'Sets the new selection as the new worksheed beginning at A
CurrFile.Sheets(1).Range("D1:N" & LRowCurr).Copy NewB.Sheets(Lvl3.Name).Range("A" & LRowNew) 'Pastes the columns D through N from the daily workbook to the new one in column A, can be changed to include more data
CurrFile.Close False 'Closes the daily workbook that the data was copied from
End If
Next
NewB.Sheets(Lvl3.Name).Columns("B:H").Delete 'Deletes columns B through H which include data not needed, can be changed to keep
NewB.Sheets(Lvl3.Name).Range("A1").Value = "PkgID" 'Creates a header for column A as PkgID
NewB.Sheets(Lvl3.Name).Range("B1").Value = "Max Cycle Time" 'Creates a header for column B as Max Cycle Time
NewB.Sheets(Lvl3.Name).Range("C1").Value = "Avg Cycle Time" 'Creates a header for column C as Avg Cycle Time
NewB.Sheets(Lvl3.Name).Range("D1").Value = "Min Cycle Time" 'Creates a header for column D as Min Cycle Time
NewB.Sheets(Lvl3.Name).Columns.AutoFit 'Autofits all the columns in the new workbook
NewB.Sheets(Lvl3.Name).Rows("1:1").Font.Bold = True 'Bolds the headers that were just added
NxtL3Fldr: 'Continues to the next level 3 folder in the loop
Next
Application.DisplayAlerts = False 'Turnes off alerts that would appear when closing worksheets
NewB.Sheets(1).Delete 'Deletes the sheet1 added to workbooks
Application.DisplayAlerts = True 'Turns alerts back on
'////////////////////////////////////////////Median Summary Additions\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
NewB.Activate 'Make sure NewB is the active book
Sheets.Add After:=Sheets(Sheets.Count) 'Add sheet to end
Sheets(Sheets.Count).Name = "Summary" 'Name added sheet Summary
For Each Sh In ActiveWorkbook.Sheets 'Loop through each sheet in the workbook
LRowS = Sheets("Summary").Range("A" & Rows.Count).End(xlUp).Row 'Find last used row
If Sh.Name <> "Summary" Then 'Skip the summary sheet
LRowR = Sh.Range("A" & Rows.Count).End(xlUp).Row 'Find the last used row in the sheet being looped through
If LRowR <= 2 Then GoTo NxtSht 'If it's less than 2 it's probably blank so skip
Sh.Range("A2:A" & LRowR).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheets("Summary").Range("A" & LRowS + 1), Unique:=True 'Copy the unique PkgID's to the summary sheet
End If
NxtSht:
Next
Sheets("Summary").Range("A1:A" & LRowS).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheets("Summary").Range("B2"), Unique:=True 'Copy the unique PkgID's to column B (removes duplicates accross sheets
Sheets("Summary").Columns(1).Delete 'Delete column A as no longer needed
Sheets("Summary").Range("A1").Value = "Pkgid" 'Add header to column A
Sheets("Summary").Columns(1).SpecialCells(xlCellTypeBlanks).Delete (xlShiftUp) 'Remove any blanks
LRowS = Sheets("Summary").Range("A" & Rows.Count).End(xlUp).Row 'Find the last used row of unique PkgID's
Col = 2 'Set Col as 2 (starts at column B), because the Median formula requires R1C1 notation
CL = -1 'Again for the R1C1 notation
CS = 2 'Again for the R1C1 notation
Application.Calculation = xlCalculationManual
For Each Sh In ActiveWorkbook.Sheets 'Loop through each sheet in the workbook
If Sh.Name <> "Summary" Then 'Skip the summary sheet
Sheets("Summary").Cells(1, Col).Value = Sh.Name 'Add header as sheet name
Sheets("Summary").Cells(2, Col).FormulaArray = "=MEDIAN(IF('" & Sh.Name & "'!C[" & CL & "]=Summary!RC[" & CL & "], '" & Sh.Name & "'!C[" & CS & "]))" 'Median array formula, Looks at value in Summary ColA to match in looped Sheet ColA, Returns Median from ColD
Sheets("Summary").Cells(2, Col).AutoFill Destination:=Range(Cells(2, Col), Cells(LRowS, Col)) 'AuotFill down for the rest of the PkgID numbers
Col = Col + 1 'Increment the column by 1 for the next sheet
CL = CL - 1 'Decrement the R1C1 notation
CS = CS - 1 'Decrement the R1C1 notation
End If
Next
Application.Calculation = xlCalculationAutomatic
Sheets("Summary").Columns.AutoFit 'AutoFit columns
Sheets("Summary").Rows("1:1").Font.Bold = True 'Make the header row bold
'////////////////////////////////////////////Median Summary Additions\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
NewB.SaveAs "C:\Users\tnrhodges\Desktop\" & DateFldr & "\SA" & Lvl2.Name & ".xlsx" 'Saves the new workbook in this directory as an xlsx with the level 2 name and SA, can be changed for different computers
NewB.Close False 'Closes the new workbook
NxtL2Fldr: 'Continues to the next level 2 folder in the loop
Next
Set NewSmryB = Workbooks.Add(1)
Set SumFldr = FSO.GetFolder("C:\Users\tnrhodges\Desktop\" & DateFldr).Files
For Each SumFile In SumFldr
Set EBook = Workbooks.Open(SumFile)
MasterBook.Sheets("Template").Copy After:=NewSmryB.Sheets(NewSmryB.Sheets.Count)
NewSmryB.Sheets(NewSmryB.Sheets.Count).Name = "Summary " & Left(EBook.Name, InStr(1, EBook.Name, ".") - 1)
LRowE = EBook.Sheets("Summary").Range("A" & Rows.Count).End(xlUp).Row
LColE = EBook.Sheets("Summary").Cells(1, Columns.Count).End(xlToLeft).Column
EBook.Sheets("Summary").Range("A2:A" & LRowE).Copy
NewSmryB.Sheets(Sheets.Count).Range("B8").PasteSpecial xlPasteValues
EBook.Sheets("Summary").Range(EBook.Sheets("Summary").Cells(1, 2), EBook.Sheets("Summary").Cells(LRowE, LColE)).Copy
NewSmryB.Sheets(NewSmryB.Sheets.Count).Range("F7").PasteSpecial xlPasteValues
Application.CutCopyMode = False
EBook.Close False
Next
NewSmryB.SaveAs "C:\Users\tnrhodges\Desktop\" & DateFldr & "\Summary " & DateFldr & ".xlsx"
Canceled: 'Cancel routine to prevent errors when selecting dates at beginning of macro
Application.ScreenUpdating = True 'Turns screen updating back on
Exit Sub
ErrHandler:
Application.ScreenUpdating = True
a = MsgBox("An error occured, please check created files and try again" & vbNewLine & "If error persists please contact Ryan Hodges", vbCritical)
End SubThe error happens on the line "Sheets("Summary").Range("A1:A & LRowS). AdvanceFilter Action:=xlFiltercopy, CopyToRange:=Sheets("Summary").Range("B2"), Unique:=True
