Sort Excel worksheets based on name, which is a date - excel

Question

So I've got this Excel workbook that has some macro's. Users are presented with a button to either create a worksheet with the current date as name, or enter a date manually and that worksheet will be created.
Now the issue: The worksheet has two sheet ('Initial' and 'Version') that must be first and last. However, all worksheets created in between should be sorted on date everytime a new sheet is created. And I mean sorted on date, the sheets are 'DD-MM-YY' so e.g. I could have names like '1-11-21', '2-11-21', '11-11-21' and '21-11-21' in the same workbook and it should be sorted ascending.
Any suggestions? A normal sort just messes things up I found (1-11-21 and 11-11-21, followed by '2-11-21' and '21-11-21'....
Thanks,
Jasper

Answer 1

Sorting sheets of a workbook is rather easy, there a numerous examples out there, looking more or less like this:
Sub SortSheets(Optional wb As Workbook = Nothing)
If wb Is Nothing Then Set wb = ActiveWorkbook ' (or maybe ThisWorkbook)
Application.ScreenUpdating = False
Dim i As Long, j As Long
For i = 1 To wb.Worksheets.Count - 1
For j = i + 1 To wb.Worksheets.Count
' ==> The following line needs to be replaced!
If wb.Worksheets(j).Name < wb.Worksheets(i).Name Then
wb.Worksheets(j).Move before:=wb.Worksheets(i)
End If
Next j
Next i
' Application.ScreenUpdating = True
End Sub
The only logic you need to change now is the If-statement. Instead of comparing the names of the sheets, you need to find a custom logic that compares the names of the two sheets.
Your logic is basically: If the name is Initial, sort it to the top, if it is Version, sort it to the end and for all the others, sort them by the date the name is representing.
I created a small function that calculates a number from the name. The Initial sheets gets 0, the Version gets a arbitrary high number, a worksheet with a date in the name gets the date value (a date is basically a double value in VBA) by converting the name into the date. If the name cannot be converted to a date, the value will be so that the sheet will be sorted to the end (but before the version sheet).
Function getSortNumber(ws As Worksheet) As Double
Const MaxNumber = 100000
If ws.Name = "Initial" Then
' Sort Initial to the beginning
getSortNumber = 0
ElseIf ws.Name = "Version" Then
' Sort Version to the end
getSortNumber = MaxNumber + ws.Parent.Sheets.Count
Else
' Create real date fom name
Dim d As Date, tokens() As String
tokens = Split(ws.Name, "-")
On Error Resume Next
d = DateSerial(Val(tokens(2)), Val(tokens(1)), Val(tokens(0)))
On Error GoTo 0
If d = 0 Then
' Failed to convert to date, sort to end
getSortNumber = MaxNumber + ws.Index
Else
' Sort according to the date value
getSortNumber = CDbl(d)
End If
End If
End Function
You can adapt the function easily if your needs changed (eg date format, or you can have extra text with the date, or you want to sort the version sheet to the beginning, or you have additional sheets with different names...). The sort function itself will not change at all, only the comparison logic.
Now all you have to do is change the line in the sort routine:
If wb.Worksheets(j).Name < wb.Worksheets(i).Name Then
to
If getSortNumber(wb.Worksheets(j)) < getSortNumber(wb.Worksheets(i)) Then

Answer 2

The general approach of converting the sheet names (that, hopefully, look like dates) to actual date serial numbers, and sorting those has been answered. But there is a a bit more to it than other answers show.
If your sheet names are user entered, you should handle a bit of variability
No need to reinvent Date Conversion, use whats already in Excel/VBA. But you need to define what year a 2 digit number represents, specifically which century it's in.
Note: How DateSerial interprets 2 digit dates is a bit complex. Refer to the docs for details
Decide what you want to do with sheets whose names cannot be converted to valid dates. Options include
Clean them up. eg
remove excess white space
allow for suffixes (times?)
alternate delimiters
other date forms (eg 1 Oct 2020)
etc
Aborting
Delete them
Move them to a defined location
Move them to another workbook
Prompt user for a new valid name
Generate a new valid name in the code
etc
Once the date serial numbers are created, you sort that data. Many options exist
Use the Dynamic Array function SORT, if you have it
If you don't, there are many Array Sort algorithms and implementations available for VBA
Examples 1 2
Use a data structure that supports Sorting. Example System.Collections.ArrayList 1
Dump the data onto a sheet and use Excel Sort
Once you have the sorted data, move the sheets into place. Note: another answer provide a nested For loop. This executes in order n^2 (n = number of sheets) May not matter for a smallish number of sheets, but will get much slower as the number of sheets increases. But it's easily avoided, see the code below.
Suggested methodoligy, including comments on what to change to suit your needs. Run this after the user has inserted a new sheet.
Sub SortSheets()
Dim ws As Worksheet
Dim wb As Workbook
Dim idx As Long
Dim SheetNames As Variant
Set wb = ThisWorkbook ' or specify the book you want
' Validate book contents
On Error Resume Next
Set ws = wb.Worksheets("Initial")
On Error GoTo 0
If ws Is Nothing Then
' Initial Doesn't exist. What now?
Exit Sub
End If
If ws.Index <> 1 Then
' Move it to first
ws.Move Before:=wb.Worksheets(1)
End If
On Error Resume Next
Set ws = wb.Worksheets("Version")
On Error GoTo 0
If ws Is Nothing Then
' Version Doesn't exist. What now?
Exit Sub
End If
If ws.Index <> wb.Worksheets.Count Then
' Move it to last
ws.Move After:=wb.Worksheets(wb.Worksheets.Count)
End If
' For each sheet between first and last,
' Convert Name to a dateSerial
' Handle any invalidly named sheets
ReDim SheetNames(2 To wb.Worksheets.Count - 1, 1 To 2)
For idx = 2 To wb.Worksheets.Count - 1
Set ws = wb.Worksheets(idx)
On Error Resume Next
' convert sheet name to date
SheetNames(idx, 1) = getDate(ws.Name)
On Error GoTo 0
If IsEmpty(SheetNames(idx, 1)) Then
' Invalid Sheet Name format. What Now?
' eg move it to the end (before Version)
SheetNames(idx, 1) = 3000000
' change to handle as you require, eg Delete it, Prompt user for a new name, etc
End If
SheetNames(idx, 2) = ws.Name
Next
' Sort on date using Dynamic Array Function SORT
SheetNames = Application.Sort(SheetNames)
' If SORT is not available, there are many Array Sort algorithms and implementations available
' Move sheets into position
' SheetNames is a 2D array of the DateSerial numbers and actual sheet names, sorted in the order we want them in the book
' Loop through the array lowest to highest,
' Get a reference to the sheet by name
' Move it to its required position (if it's not already there)
For idx = 1 To UBound(SheetNames, 1)
Set ws = wb.Worksheets(SheetNames(idx, 2))
If ws.Index <> idx + 1 Then
ws.Move After:=wb.Worksheets(idx)
End If
Next
End Sub
Function getDate(DateStr As String, Optional Delim As String = "-") As Long
' Cleanup sheet name
' Add or remove cleaning to suit your needs
' reduce multiple space sequences to single spaces
DateStr = Application.WorksheetFunction.Trim(DateStr)
' remove spaces aroung delimiter
DateStr = Replace$(DateStr, " " & Delim, Delim) '
DateStr = Replace$(DateStr, Delim & " ", Delim)
' replace any remaining spaces with delimiter (needed to make Val() work as desired)
DateStr = Replace$(DateStr, " ", Delim)
' Create real date from name
Dim d As Long, Segments() As String
Segments = Split(DateStr, Delim)
If UBound(Segments) < 2 Then
' not enough segments
d = 0
ElseIf UBound(Segments) > 2 Then
' too many segments. What Now?
' do nothing if it's acceptable to ignore anything after the date
Else
' Segment(0) is first part, assumed to be Day
' Segment(1) is second part, assumed to be Month
' Segment(2) is third part, assumed to be Year
' assume 2 digit dates are 2000's. Change to suit your needs
' Note: relying on DateSerial to convert 2 digit dates may give unexpected results
' as what you get depends on Excel version and local settings
If Len(Segments(2)) <= 2 Then Segments(2) = "20" & Format$(Segments(2), "00")
On Error Resume Next
d = CLng(DateSerial(CInt(Val(Segments(2))), CInt(Segments(1)), CInt(Segments(0))))
On Error GoTo 0
End If
If d = 0 Then
' Could not convert to date. Let calling routine decide what to do now
Err.Raise 1, "getDate", "Invalid Date string"
Else
' return date value
getDate = d
End If
End Function

Answer 3

Insert Date Worksheet
Note the following in two-digit year notation:
01/01/30 ... 01/01/1930
12/31/99 ... 12/31/1999
01/01/00 ... 01/01/2000
12/31/29 ... 12/31/2029
Some complications are present due to:
Sub Test1()
Debug.Print DateSerial(111, 22, 33) ' Result '11/02/112'
Debug.Print DateSerial(21, 2, 30) ' Result ' 03/02/2021
End Sub
The following will not sort any previously added worksheets. It will just insert the new worksheet in the right spot i.e. before the first worksheet with a greater date than the date supplied, or before the last worksheet (if no greater date).
Option Explicit
Sub InsertDateWorksheet()
' Needs 'RefWorksheet', 'InputDateText', 'GetTwoDigitYearDate' and 'IsLeapYear'.
Const ProcName As String = "InsertDateWorksheet"
Const First As String = "Initial"
Const Last As String = "Version"
Const Delimiter As String = "-"
Dim wb As Workbook: Set wb = ThisWorkbook
' First Worksheet
Dim fws As Worksheet: Set fws = RefWorksheet(wb, First, True)
If fws Is Nothing Then Exit Sub
If Not fws Is wb.Sheets(1) Then
fws.Move Before:=wb.Sheets(1)
End If
' Last Worksheet
Dim lws As Worksheet: Set lws = RefWorksheet(wb, Last, True)
If lws Is Nothing Then Exit Sub
Dim shCount As Long: shCount = wb.Sheets.Count
If Not lws Is wb.Sheets(shCount) Then
lws.Move After:=wb.Sheets(shCount)
End If
Dim NewDate As Date: NewDate = InputDateText(True)
If NewDate = 0 Then Exit Sub
Dim NewDateString As String: NewDateString = CStr(Day(NewDate)) _
& Delimiter & CStr(Month(NewDate)) & Delimiter _
& Right(CStr(Year(NewDate)), 2)
Dim nws As Worksheet: Set nws = RefWorksheet(wb, NewDateString)
If Not nws Is Nothing Then
MsgBox "The worksheet '" & NewDateString & "' already exists.", _
vbCritical, ProcName
Exit Sub
End If
Dim ws As Worksheet
Dim wsDate As Date
For Each ws In wb.Worksheets
Select Case ws.Name
Case First
Case Last
Exit For
Case Else
wsDate = GetTwoDigitYearDate(ws.Name, Delimiter)
If NewDate < wsDate Then
Exit For
End If
End Select
Next ws
Worksheets.Add(Before:=ws).Name = NewDateString
MsgBox "Worksheet '" & NewDateString & "' added.", vbInformation, ProcName
End Sub
Function RefWorksheet( _
ByVal wb As Workbook, _
ByVal WorksheetName As String, _
Optional ByVal DoWriteMessage As Boolean = False) _
As Worksheet
Const ProcName As String = "RefWorksheet"
On Error Resume Next
Set RefWorksheet = wb.Worksheets(WorksheetName)
On Error GoTo 0
If DoWriteMessage Then
If RefWorksheet Is Nothing Then
MsgBox "Worksheet '" & WorksheetName & "' not found.", _
vbCritical, ProcName
Exit Function
End If
End If
End Function
Function InputDateText( _
Optional ByVal DoWriteMessage As Boolean = False) _
As Date
' Needs 'GetTwoDigitYearDate' and 'IsLeapYear'.
Const ProcName As String = "InputDateText"
Const InputFormat As String = "d-m-yy"
Const nTitle As String = "Input Date Text"
Dim nPrompt As String
nPrompt = "Please enter a date in '" & InputFormat & "' format..."
Dim nDefault As String: nDefault = Format(Date, InputFormat)
Dim NewDateString As Variant: NewDateString = Application.InputBox( _
nPrompt, nTitle, nDefault, , , , , 2)
If NewDateString = False Then
MsgBox "You canceled.", vbExclamation, ProcName
Exit Function
End If
InputDateText = GetTwoDigitYearDate(NewDateString, "-")
If DoWriteMessage Then
If InputDateText = 0 Then
MsgBox "The string '" & NewDateString & "' is not valid.", _
vbCritical, ProcName
End If
End If
End Function
Function GetTwoDigitYearDate( _
ByVal DateString As String, _
Optional ByVal Delimiter As String = "-") _
As Date
' Needs 'IsLeapYear'.
On Error GoTo ClearError
Dim ArrDate() As String: ArrDate = Split(DateString, Delimiter)
Dim nYear As Long: nYear = CLng(ArrDate(2))
Select Case nYear
Case Is < 0, Is > 99
Exit Function
Case Else
nYear = IIf(nYear > 29, nYear + 1900, nYear + 2000)
End Select
Dim nMonth As Long: nMonth = CLng(ArrDate(1))
Select Case nMonth
Case Is < 1, Is > 12
Exit Function
End Select
Dim nDay As Long: nDay = CLng(ArrDate(0))
Select Case nDay
Case Is < 1, Is > 31
Exit Function
End Select
Select Case nMonth
Case 4, 6, 9, 11
If nDay = 31 Then Exit Function
Case 2
If nDay > 29 Then Exit Function
If nDay = 29 Then
If Not IsLeapYear(nYear) Then Exit Function
End If
End Select
GetTwoDigitYearDate = DateSerial(nYear, nMonth, nDay)
ProcExit:
Exit Function
ClearError:
Resume ProcExit
End Function
Function IsLeapYear( _
TestYear As Long) _
As Boolean
If TestYear Mod 4 = 0 Then
If TestYear Mod 100 = 0 Then
If TestYear Mod 400 = 0 Then
' Accounting for e.g. years 2000, 2400, 2800...8800, 9200, 9600.
IsLeapYear = True
'Else
' Accounting for e.g. years 2100, 2200, 2300...9700, 9800, 9900.
'isLeapYear = False
End If
Else
' Accounting for e.g. years 1904, 1908, 1912...1988, 1992, 1996.
IsLeapYear = True
End If
'Else
' Accounting for e.g. years 1901, 1902, 1903...1997, 1998, 1999.
'isLeapYear = False
End If
End Function