根据名称（日期）对 Excel 个工作表进行排序
Sort Excel worksheets based on name, which is a date
所以我有这个 Excel 工作簿，其中有一些宏。用户会看到一个按钮，可以创建一个以当前日期作为名称的作品sheet，或者手动输入一个日期，然后将创建该作品sheet。
现在的问题是：作品sheet有两个sheet（'Initial'和'Version'），它们必须是第一个和最后一个。但是，每次创建新的 sheet 时，其间创建的所有作品sheet 都应按日期排序。我的意思是按日期排序，sheet 是 'DD-MM-YY'，例如我可以在同一个工作簿中使用诸如“1-11-21”、“2-11-21”、“11-11-21”和“21-11-21”之类的名称，它们应该按升序排序。
有什么建议吗？正常的排序只会把我发现的东西弄乱（1-11-21 和 11-11-21，然后是“2-11-21”和“21-11-21”....
谢谢，
贾斯珀
对工作簿进行排序 sheet 相当容易，这里有很多示例，大致如下所示：
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
您现在唯一需要更改的逻辑是 If 语句。您需要找到一个自定义逻辑来比较两个 sheet 的名称，而不是比较 sheet 的名称。
你的逻辑基本上是：如果名称是 Initial，则将其排序到顶部，如果是 Version，则将其排序到末尾，对于所有其他名称，按名字代表的日期。
我创建了一个根据名称计算数字的小函数。 Initial sheets 获取 0，Version 获取任意高数，名称中带有日期的作品sheet 获取日期值（日期基本上是一个VBA) 中的双精度值，方法是将名称转换为日期。如果名称无法转换为日期，则该值将 sheet 排序到末尾（但在版本 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
如果您的需求发生变化（例如日期格式，或者您可以使用带有日期的额外文本，或者您希望将版本 sheet 排序到开头，或者您有额外的sheet 有不同的名字...）。 sort函数本身是完全不会变的，只是比较逻辑。
现在您所要做的就是更改排序例程中的行：
If wb.Worksheets(j).Name < wb.Worksheets(i).Name Then
至
If getSortNumber(wb.Worksheets(j)) < getSortNumber(wb.Worksheets(i)) Then
插入日期工作表
请注意以下两位数年份表示法：
01/01/30 ... 01/01/1930
12/31/99 ... 12/31/1999
01/01/00 ... 01/01/2000
12/31/29 ... 12/31/2029
一些并发症是由于：
Sub Test1()
Debug.Print DateSerial(111, 22, 33) ' Result '11/02/112'
Debug.Print DateSerial(21, 2, 30) ' Result ' 03/02/2021
End Sub
以下不会对任何以前添加的工作表进行排序。它只会将新工作表插入正确的位置，即在日期大于提供日期的第一个工作表之前，或者在最后一个工作表之前（如果没有更大的日期）。
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
将 sheet 名称（希望看起来像日期）转换为实际日期序列号并对其进行排序的一般方法已得到解答。但它比其他答案显示的要多一些。
- 如果您的 sheet 名称是用户输入的，您应该处理一些可变性
- 无需重新发明日期转换，使用 Excel/VBA 中已有的内容。但是你需要定义一个2位数字代表的年份，具体是哪个世纪。
注意：DateSerial 如何解释 2 位日期有点复杂。 Refer to the docs for details
- 决定要如何处理 sheet 姓名无法转换为有效日期的人。选项包括
- 清理它们。例如
- 去除多余的白色space
- 允许后缀（时间？）
- 备用分隔符
- 其他日期形式（例如
1 Oct 2020）
- 等等
- 正在中止
- 删除它们
- 将它们移动到定义的位置
- 将它们移动到另一个工作簿
- 提示用户输入新的有效名称
- 在代码中生成一个新的有效名称
- 等等
- 创建日期序列号后，您可以对 that 数据进行排序。存在许多选项
- 使用动态数组函数
SORT，如果你有
- 如果您不这样做，有许多数组排序算法和实现可用于 VBA
示例 1 2
- 使用支持排序的数据结构。示例
System.Collections.ArrayList 1
- 将数据转储到 sheet 并使用 Excel 排序
- 获得排序后的数据后，将 sheet 移动到位。注意：另一个答案提供了一个嵌套的 For 循环。这按顺序执行 n^2（n = sheets 的数量）对于少量的 sheets 可能无关紧要，但随着 sheets 的数量增加会变得更慢.但是很容易避免，看下面的代码。
建议的方法论，包括关于根据您的需要进行更改的评论。 运行 此 在 用户插入了一个新的 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
所以我有这个 Excel 工作簿，其中有一些宏。用户会看到一个按钮，可以创建一个以当前日期作为名称的作品sheet，或者手动输入一个日期，然后将创建该作品sheet。
现在的问题是：作品sheet有两个sheet（'Initial'和'Version'），它们必须是第一个和最后一个。但是，每次创建新的 sheet 时，其间创建的所有作品sheet 都应按日期排序。我的意思是按日期排序，sheet 是 'DD-MM-YY'，例如我可以在同一个工作簿中使用诸如“1-11-21”、“2-11-21”、“11-11-21”和“21-11-21”之类的名称，它们应该按升序排序。
有什么建议吗？正常的排序只会把我发现的东西弄乱（1-11-21 和 11-11-21，然后是“2-11-21”和“21-11-21”....
谢谢，
贾斯珀
对工作簿进行排序 sheet 相当容易，这里有很多示例，大致如下所示：
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
您现在唯一需要更改的逻辑是 If 语句。您需要找到一个自定义逻辑来比较两个 sheet 的名称，而不是比较 sheet 的名称。
你的逻辑基本上是：如果名称是 Initial，则将其排序到顶部，如果是 Version，则将其排序到末尾，对于所有其他名称，按名字代表的日期。
我创建了一个根据名称计算数字的小函数。 Initial sheets 获取 0，Version 获取任意高数，名称中带有日期的作品sheet 获取日期值（日期基本上是一个VBA) 中的双精度值，方法是将名称转换为日期。如果名称无法转换为日期，则该值将 sheet 排序到末尾（但在版本 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
如果您的需求发生变化（例如日期格式，或者您可以使用带有日期的额外文本，或者您希望将版本 sheet 排序到开头，或者您有额外的sheet 有不同的名字...）。 sort函数本身是完全不会变的，只是比较逻辑。
现在您所要做的就是更改排序例程中的行：
If wb.Worksheets(j).Name < wb.Worksheets(i).Name Then
至
If getSortNumber(wb.Worksheets(j)) < getSortNumber(wb.Worksheets(i)) Then
插入日期工作表
请注意以下两位数年份表示法：
01/01/30 ... 01/01/1930 12/31/99 ... 12/31/1999 01/01/00 ... 01/01/2000 12/31/29 ... 12/31/2029一些并发症是由于：
Sub Test1() Debug.Print DateSerial(111, 22, 33) ' Result '11/02/112' Debug.Print DateSerial(21, 2, 30) ' Result ' 03/02/2021 End Sub以下不会对任何以前添加的工作表进行排序。它只会将新工作表插入正确的位置，即在日期大于提供日期的第一个工作表之前，或者在最后一个工作表之前（如果没有更大的日期）。
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
将 sheet 名称（希望看起来像日期）转换为实际日期序列号并对其进行排序的一般方法已得到解答。但它比其他答案显示的要多一些。
- 如果您的 sheet 名称是用户输入的，您应该处理一些可变性
- 无需重新发明日期转换，使用 Excel/VBA 中已有的内容。但是你需要定义一个2位数字代表的年份，具体是哪个世纪。
注意：DateSerial 如何解释 2 位日期有点复杂。 Refer to the docs for details - 决定要如何处理 sheet 姓名无法转换为有效日期的人。选项包括
- 清理它们。例如
- 去除多余的白色space
- 允许后缀（时间？）
- 备用分隔符
- 其他日期形式（例如
1 Oct 2020） - 等等
- 正在中止
- 删除它们
- 将它们移动到定义的位置
- 将它们移动到另一个工作簿
- 提示用户输入新的有效名称
- 在代码中生成一个新的有效名称
- 等等
- 清理它们。例如
- 创建日期序列号后，您可以对 that 数据进行排序。存在许多选项
- 使用动态数组函数
SORT，如果你有 - 如果您不这样做，有许多数组排序算法和实现可用于 VBA
示例 1 2 - 使用支持排序的数据结构。示例
System.Collections.ArrayList1 - 将数据转储到 sheet 并使用 Excel 排序
- 使用动态数组函数
- 获得排序后的数据后，将 sheet 移动到位。注意：另一个答案提供了一个嵌套的 For 循环。这按顺序执行 n^2（n = sheets 的数量）对于少量的 sheets 可能无关紧要，但随着 sheets 的数量增加会变得更慢.但是很容易避免，看下面的代码。
建议的方法论，包括关于根据您的需要进行更改的评论。 运行 此 在 用户插入了一个新的 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