Filters and then sorting
I have a code that works, however I am working on cleaning up my codes I use. This code is stored in ThisWorkbook and run under Workbook_BeforeClose(Cancel As Boolean). Is there a cleaner way of doing it, rather shortening it. Since it is working with filter and sorting there is a 3 blank column in between each day set. Each day contains a different amount of times.
Private Sub Workbook_BeforeClose(Cancel As Boolean)
' Sort Macro
'
Application.ScreenUpdating = False
Worksheets("RoadMap").Activate
Range("C3:D151").Select '''Selects column
Application.DeleteCustomList ListNum:=5
Application.AddCustomList ListArray:=Array("TRN", "PIT-G", "PIT-D", "PIT-S", "F-230A", "F-330A", "F-430A", "F-830A", "F-930A", "F-1030A", "F-1130A", "F-1230P", "F-130P", "F-230P", "F-430P", "F-530P", "F-630P", "F-730P", "F-830P", "F-930P", "4AM", "5AM", "T-6AM", "8AM", "9AM", "10AM", "11AM", "12PM", "1PM", "2PM", "3PM", "4PM", "5PM", "T-6PM", "6PM", "7PM", "8PM", "9PM", "10PM", "11PM") 'Column contains these starts to be in this order
'''''Data will be added daily and sorted into proper order
ActiveWorkbook.Worksheets("RoadMap").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("RoadMap").Sort.SortFields.Add Key:=Range("C3:C151"), SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:= "TRN,PIT-G,PIT-D,PIT-S,F-230A,F-330A,F-430A,F-830A,F-930A,F-1030A,F-1130A,F-1230P,F-130P,F-230P,F-430P,F-530P,F-630P,F-730P,F-830P,F-930P,4AM,5AM,T-6AM,8AM,9AM,10AM,11AM,12PM,1PM,2PM,3PM,4PM,5PM,T-6PM,6PM,7PM,8PM,9PM,10PM,11PM", DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("RoadMap").Sort
.SetRange Range("C2:D151")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'''''Repeats for each column that has the data for days of the week M-S
Range("H3:I151").Select 'repeats previous for the next range of columns with data
Application.DeleteCustomList ListNum:=5
Application.AddCustomList ListArray:=Array("TRN", "PIT-G", "PIT-D", "PIT-S", _
"F-230A", "F-330A", "F-430A", "F-830A", "F-930A", "F-1030A", "F-1130A", "F-1230P", "F-130P", "F-230P", "F-430P", "F-530P", "F-630P", "F-730P", "F-830P", "F-930P", "4AM", "5AM", _
"T-6AM", "8AM", "9AM", "10AM", "11AM", "12PM", "1PM", "2PM", "3PM", "4PM", "5PM", "T-6PM", "6PM", "7PM", "8PM", "9PM", "10PM", "11PM")
'sorting order
ActiveWorkbook.Worksheets("RoadMap").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("RoadMap").Sort.SortFields.Add Key:=Range("H4:H151"), SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:= "TRN,PIT-G,PIT-D,PIT-S,F-230A,F-330A,F-430A,F-830A,F-930A,F-1030A,F-1130A,F-1230P,F-130P,F-230P,F-430P,F-530P,F-630P,F-730P,F-830P,F-930P,4AM,5AM,T-6AM,8AM,9AM,10AM,11AM,12PM,1PM,2PM,3PM,4PM,5PM,T-6PM,6PM,7PM,8PM,9PM,10PM,11PM", DataOption:=xlSortNormal
'sorting
With ActiveWorkbook.Worksheets("RoadMap").Sort
.SetRange Range("H3:I151")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'next column
Range("M3:N151").Select
Application.DeleteCustomList ListNum:=5
Application.AddCustomList ListArray:=Array("TRN", "PIT-G", "PIT-D", "PIT-S", "F-230A", "F-330A", "F-430A", "F-830A", "F-930A", "F-1030A", "F-1130A", "F-1230P", "F-130P", "F-230P", "F-430P", "F-530P", "F-630P", "F-730P", "F-830P", "F-930P", "4AM", "5AM", "T-6AM", "8AM", "9AM", "10AM", "11AM", "12PM", "1PM", "2PM", "3PM", "4PM", "5PM", "T-6PM", "6PM", "7PM", "8PM", "9PM", "10PM", "11PM")
'sorting order
ActiveWorkbook.Worksheets("RoadMap").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("RoadMap").Sort.SortFields.Add Key:=Range("M4:M151"), SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:= "TRN,PIT-G,PIT-D,PIT-S,F-230A,F-330A,F-430A,F-830A,F-930A,F-1030A,F-1130A,F-1230P,F-130P,F-230P,F-430P,F-530P,F-630P,F-730P,F-830P,F-930P,4AM,5AM,T-6AM,8AM,9AM,10AM,11AM,12PM,1PM,2PM,3PM,4PM,5PM,T-6PM,6PM,7PM,8PM,9PM,10PM,11PM", DataOption:=xlSortNormal
'sorting
With ActiveWorkbook.Worksheets("RoadMap").Sort
.SetRange Range("M3:N151")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'next column
Range("R3:S151").Select
Application.DeleteCustomList ListNum:=5
Application.AddCustomList ListArray:=Array("TRN", "PIT-G", "PIT-D", "PIT-S", "F-230A", "F-330A", "F-430A", "F-830A", "F-930A", "F-1030A", "F-1130A", "F-1230P", "F-130P", "F-230P", "F-430P", "F-530P", "F-630P", "F-730P", "F-830P", "F-930P", "4AM", "5AM", "T-6AM", "8AM", "9AM", "10AM", "11AM", "12PM", "1PM", "2PM", "3PM", "4PM", "5PM", "T-6PM", "6PM", "7PM", "8PM", "9PM", "10PM", "11PM")
'sorting order
ActiveWorkbook.Worksheets("RoadMap").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("RoadMap").Sort.SortFields.Add Key:=Range("R4:R151"), SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:= "TRN,PIT-G,PIT-D,PIT-S,F-230A,F-330A,F-430A,F-830A,F-930A,F-1030A,F-1130A,F-1230P,F-130P,F-230P,F-430P,F-530P,F-630P,F-730P,F-830P,F-930P,4AM,5AM,T-6AM,8AM,9AM,10AM,11AM,12PM,1PM,2PM,3PM,4PM,5PM,T-6PM,6PM,7PM,8PM,9PM,10PM,11PM", DataOption:=xlSortNormal
'sorting
With ActiveWorkbook.Worksheets("RoadMap").Sort
.SetRange Range("R3:S151")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'next column
Range("W3:X151").Select
Application.DeleteCustomList ListNum:=5
Application.AddCustomList ListArray:=Array("TRN", "PIT-G", "PIT-D", "PIT-S", "F-230A", "F-330A", "F-430A", "F-830A", "F-930A", "F-1030A", "F-1130A", "F-1230P", "F-130P", "F-230P", "F-430P", "F-530P", "F-630P", "F-730P", "F-830P", "F-930P", "4AM", "5AM", "T-6AM", "8AM", "9AM", "10AM", "11AM", "12PM", "1PM", "2PM", "3PM", "4PM", "5PM", "T-6PM", "6PM", "7PM", "8PM", "9PM", "10PM", "11PM")
'sorting order
ActiveWorkbook.Worksheets("RoadMap").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("RoadMap").Sort.SortFields.Add Key:=Range("W4:W151"), SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:= "TRN,PIT-G,PIT-D,PIT-S,F-230A,F-330A,F-430A,F-830A,F-930A,F-1030A,F-1130A,F-1230P,F-130P,F-230P,F-430P,F-530P,F-630P,F-730P,F-830P,F-930P,4AM,5AM,T-6AM,8AM,9AM,10AM,11AM,12PM,1PM,2PM,3PM,4PM,5PM,T-6PM,6PM,7PM,8PM,9PM,10PM,11PM", DataOption:=xlSortNormal
'sorting
With ActiveWorkbook.Worksheets("RoadMap").Sort
.SetRange Range("W3:X151")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'''next column
Range("AB3:AC151").Select
Application.DeleteCustomList ListNum:=5
Application.AddCustomList ListArray:=Array("TRN", "PIT-G", "PIT-D", "PIT-S", "F-230A", "F-330A", "F-430A", "F-830A", "F-930A", "F-1030A", "F-1130A", "F-1230P", "F-130P", "F-230P", "F-430P", "F-530P", "F-630P", "F-730P", "F-830P", "F-930P", "4AM", "5AM", "T-6AM", "8AM", "9AM", "10AM", "11AM", "12PM", "1PM", "2PM", "3PM", "4PM", "5PM", "T-6PM", "6PM", "7PM", "8PM", "9PM", "10PM", "11PM")
'sorting order
ActiveWorkbook.Worksheets("RoadMap").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("RoadMap").Sort.SortFields.Add Key:=Range("AB4:AB151"), SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:= "TRN,PIT-G,PIT-D,PIT-S,F-230A,F-330A,F-430A,F-830A,F-930A,F-1030A,F-1130A,F-1230P,F-130P,F-230P,F-430P,F-530P,F-630P,F-730P,F-830P,F-930P,4AM,5AM,T-6AM,8AM,9AM,10AM,11AM,12PM,1PM,2PM,3PM,4PM,5PM,T-6PM,6PM,7PM,8PM,9PM,10PM,11PM", DataOption:=xlSortNormal
'sorting
With ActiveWorkbook.Worksheets("RoadMap").Sort
.SetRange Range("AB3:AC151")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'next column
Range("AG3:AH151").Select
Application.DeleteCustomList ListNum:=5
Application.AddCustomList ListArray:=Array("TRN", "PIT-G", "PIT-D", "PIT-S", "F-230A", "F-330A", "F-430A", "F-830A", "F-930A", "F-1030A", "F-1130A", "F-1230P", "F-130P", "F-230P", "F-430P", "F-530P", "F-630P", "F-730P", "F-830P", "F-930P", "4AM", "5AM", "T-6AM", "8AM", "9AM", "10AM", "11AM", "12PM", "1PM", "2PM", "3PM", "4PM", "5PM", "T-6PM", "6PM", "7PM", "8PM", "9PM", "10PM", "11PM")
''' column sort
ActiveWorkbook.Worksheets("RoadMap").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("RoadMap").Sort.SortFields.Add Key:=Range("AG4:AG151"), SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:= "TRN,PIT-G,PIT-D,PIT-S,F-230A,F-330A,F-430A,F-830A,F-930A,F-1030A,F-1130A,F-1230P,F-130P,F-230P,F-430P,F-530P,F-630P,F-730P,F-830P,F-930P,4AM,5AM,T-6AM,8AM,9AM,10AM,11AM,12PM,1PM,2PM,3PM,4PM,5PM,T-6PM,6PM,7PM,8PM,9PM,10PM,11PM", DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("RoadMap").Sort
.SetRange Range("AG3:AH151")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("A2").Select
End Sub
Solution
Shorten Code Using a Loop: Custom Sort Data
Before
After
Sub SortData()
Const SHEET_NAME As String = "RoadMap"
Const FIRST_RANGE_ADDRESS As String = "C3:D22"
Const SORT_LIST As String = "" _
& "TRN,PIT-G,PIT-D,PIT-S,F-230A," _
& "F-330A,F-430A,F-830A,F-930A,F-1030A," _
& "F-1130A,F-1230P,F-130P,F-230P,F-430P," _
& "F-530P,F-630P,F-730P,F-830P,F-930P," _
& "4AM,5AM,T-6AM,8AM,9AM," _
& "10AM,11AM,12PM,1PM,2PM," _
& "3PM,4PM,5PM,T-6PM,6PM," _
& "7PM,8PM,9PM,10PM,11PM"
Const DAYS_COUNT As Long = 7
Const COLUMN_OFFSET As Long = 5
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Sheets(SHEET_NAME)
Dim rg As Range: Set rg = ws.Range(FIRST_RANGE_ADDRESS)
Application.ScreenUpdating = False
Dim srg As Range, n As Long
For n = 1 To DAYS_COUNT
Set srg = rg.Offset(, (n - 1) * COLUMN_OFFSET)
Debug.Print n, srg.Address
With ws.Sort
With .SortFields
.Clear
.Add _
Key:=srg.Columns(1), _
SortOn:=xlSortOnValues, _
Order:=xlAscending, _
CustomOrder:=SORT_LIST, _
DataOption:=xlSortNormal
End With
.SetRange srg
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.Apply
End With
Next n
Application.ScreenUpdating = True
End Sub
- How to import values from excel with pandas into tkinter faster?
- Speed up concatenation of excel files with Pandas
- Trying to send screenshot of excel in an email
- Sum of text Does not contain in Range
- Stopping Excel Macro executution when pressing Esc won't work
- Consolidated Date window
- Excel formula for calculating difference between two date columns
- Get number of decimals in python float, including trailing zeros
- Excel VBA search for data and stuck at a certain point due to group or split source file?
- Convert Time Input in Decimal Format - Excel Formula or VBA
- Lookup unique "Values" if they follow a certain "Pattern" from a lookup table then return a "Name"
- Share office scripts connected to Excel with external organisations
- Tiling an Excel array in 2 dimensions, ideally not using VBA
- How to get the cartesian product of two sets via Excel Formulas
- Repeat Value for Every Instance of Another Value in Excel without using Power Query
- VSTACK doesn't pile up dynamic ranges
- How To Close a UserForm Properly in Excel VBA?
- In Excel, can I use a hyperlink to run vba macro?
- EXCEL: Count all unique values in Table column up to a certain point, and combine them into a single string?
- Excel VBA connection to SQL Server with Microsoft Entra MFA authentication
- Excel shows incorrect polynomial trendline function
- Split too large VBA into multiple Subs
- Trying to calculate user whos spent the most and the least - Excel
- How to do a union of two columns and then sort them into a third column in Excel?
- Is there a way to create a simple custom formula in Excel without VBA?
- Copying a String Array into a Range of cells (in MS Excel using VBA)
- vlookup with formula calculated from lookup cell location
- How to extract R InstallPath from Registry using Excel VBA
- How to inner-join in Excel (eg. using VLOOKUP)
- Scientific notation when importing from Excel in .Net