Sort Excel worksheets based on name, which is a date

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