求一个工作表排序的宏(支持按自定义序列排序)

wshcw

论坛里工作表排序的代码不少,但与现实中的实际需要不符,现求一个工作表排序,并且支持按自定义序列排序的代码.
举例:
比如附件中的工作表是乱序的,农历日期设置为自定义序列,如何调用自定义序列(对话框选择),对工作表进行排序.
附件只是一个简单例子,代码尽量适用,通用点为好.

佛山小老鼠

Option Explicit

Sub 按工作表内容升序排序工作表()
    Dim ant, arr1, X&, sh As Worksheet
    On Error Resume Next
    Set sh = Sheets("工作表名")
    If Err.Number <> 0 Then
        MsgBox "1. 请在第1个工作表名前面创建一个新的工作表名,取名为--工作表名" & Chr(10) & Chr(10) & "2. 请在A列从A1开始输入工作表名称且一定要按你要顺序输好", 64, "温馨提醒"
    Else
        Sheets("工作表名").Select
       If Cells(Rows.Count, 1).End(xlUp).Row < 3 Then
            MsgBox "请在A列从A1开始输入工作表名称且一定要按你要顺序输好", 16, "警告"
            Exit Sub
        Else
           arr1 = Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row)
           For X = UBound(arr1) To 1 Step -1
                Sheets(CStr(arr1(X, 1))).Move before:=Sheets(1)
           Next X
           MsgBox "亲:排序完毕", 64, "温馨提示"
       End If
    End If
     Sheets("工作表名").Select
End Sub


Sub 按工作表内容降序排序工作表()
    Dim ant, arr1, X&, sh As Worksheet
    On Error Resume Next
    Set sh = Sheets("工作表名")
    If Err.Number <> 0 Then
        MsgBox "1. 请在第1个工作表名前面创建一个新的工作表名,取名为--工作表名" & Chr(10) & Chr(10) & "2. 请在A列从A1开始输入工作表名称且一定要按你要顺序输好", 64, "温馨提醒"
    Else
        Sheets("工作表名").Select
       If Cells(Rows.Count, 1).End(xlUp).Row < 3 Then
            MsgBox "请在A列从A1开始输入工作表名称且一定要按你要顺序输好", 16, "警告"
            Exit Sub
        Else
           arr1 = Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row)
           For X = 1 To UBound(arr1)
                Sheets(CStr(arr1(X, 1))).Move before:=Sheets(1)
           Next X
           MsgBox "亲:排序完毕", 64, "温馨提示"
       End If
    End If
    Sheets("工作表名").Select
End Sub