VBA 操作 Excel 生成日期及星期

‘ 获取星期的显示
Function disp(i As Integer)
  Select Case i
     Case 1
       disp = "一"
     Case 2
       disp = "二"
     Case 3
       disp = "三"
     Case 4
       disp = "四"
     Case 5
       disp = "五"
     Case 6
       disp = "六"
     Case Else
       disp = "日"
  End Select
End Function

‘ 获取当月的天数
Function GetDaysOfMonth(Year As String, Month As String) As Integer
    Dim Day1, Day2 As String
    If Month = "12" Then
        GetDaysOfMonth = 31
    Else
        Day1 = Year + "-" + Month + "-1"
        Day2 = Year + "-" + CStr(CInt(Month) + 1) + "-1"
        GetDaysOfMonth = DateDiff("d", Day1, Day2)
    End If
End Function

Sub AddSheets()
    Dim i As Integer
    Dim DaysOfMonth As Integer
    Dim NameStr As String
    Dim DateStr As String
    Dim CurrMonth As Integer
    Dim MonStr As String
    Dim CurrYear As String
    Dim Choice As Integer
    Dim LastMonth As Integer
    Dim OriginSheet As String
    
    Application.DisplayAlerts = False
    For i = Sheets.Count To 1 Step -1
        If Sheets(i).Name <> ActiveSheet.Name Then
            Sheets(i).Delete
        End If
    Next
    
    ActiveSheet.Name = "LastSheet"
    OriginSheet = ActiveSheet.Name
 
    CurrMonth = CInt(Month(Now))

    ‘ 设置起始及结束月份(1-12); 默认当前月
    StartMonth = CurrMonth
    LastMonth = CurrMonth

    CurrYear = CStr(Year(Now))
    For m = StartMonth To LastMonth
        MonStr = CStr(m)
        DaysOfMonth = GetDaysOfMonth(CurrYear, MonStr)
        For i = 1 To DaysOfMonth
            Worksheets.Add after:=Worksheets(Worksheets.Count)
            NameStr = MonStr & "-" & CStr(i)
            DateStr = CurrYear & "-" & NameStr
            ActiveSheet.Name = NameStr
            ActiveSheet.[A1].Value = DateStr
            ActiveSheet.[B1].Value = "星期" & disp(Weekday(DateStr, vbMonday))
 
            ‘ 设置单元格行列宽高自适应
            ActiveSheet.[A1].Columns.AutoFit
            ActiveSheet.[A1].Rows.AutoFit
            ActiveSheet.[B1].Columns.AutoFit
            ActiveSheet.[B1].Rows.AutoFit
        Next
    Next
    Sheets(OriginSheet).Delete
    On Error Resume Next
    Application.DisplayAlerts = True
End Sub

‘ 获取星期的显示
Function disp(i As Integer)
  Select Case i
     Case 1
       disp = "一"
     Case 2
       disp = "二"
     Case 3
       disp = "三"
     Case 4
       disp = "四"
     Case 5
       disp = "五"
     Case 6
       disp = "六"
     Case Else
       disp = "日"
  End Select
End Function

‘ 获取当月的天数
Function GetDaysOfMonth(Year As String, Month As String) As Integer
    Dim Day1, Day2 As String
    If Month = "12" Then
        GetDaysOfMonth = 31
    Else
        Day1 = Year + "-" + Month + "-1"
        Day2 = Year + "-" + CStr(CInt(Month) + 1) + "-1"
        GetDaysOfMonth = DateDiff("d", Day1, Day2)
    End If
End Function

Sub AddSheets(Year As String, Month As String)
    Dim i As Integer
    Dim DaysOfMonth As Integer
    Dim NameStr As String
    Dim DateStr As String
    Dim CurrMonth As Integer
    Dim MonStr As String
    Dim OriginSheet As String
    
    For i = Sheets.Count To 1 Step -1
        If Sheets(i).Name <> ActiveSheet.Name Then
            Sheets(i).Delete
        End If
    Next
    
    ActiveSheet.Name = "LastSheet"
    OriginSheet = ActiveSheet.Name
 
    MonStr = CStr(Month)
    DaysOfMonth = GetDaysOfMonth(Year, MonStr)
    For i = 1 To DaysOfMonth
        Worksheets.Add after:=Worksheets(Worksheets.Count)
        NameStr = MonStr & "-" & CStr(i)
        DateStr = Year & "-" & NameStr
        ActiveSheet.Name = NameStr
        ActiveSheet.[A1].Value = DateStr
        ActiveSheet.[B1].Value = "星期" & disp(Weekday(DateStr, vbMonday))

        ‘ 设置单元格行列宽高自适应
        ActiveSheet.[A1].Columns.AutoFit
        ActiveSheet.[A1].Rows.AutoFit
        ActiveSheet.[B1].Columns.AutoFit
        ActiveSheet.[B1].Rows.AutoFit
    Next
    Sheets(OriginSheet).Delete
    On Error Resume Next
    
End Sub

Sub AddExcels(Year As String)
    Dim wb As Workbook
    Dim wbname As String
    Dim m As Integer
    Dim Month As String
    
    For m = 1 To 12
        Set wb = Workbooks.Add
        Month = CStr(m)
        Call AddSheets(Year, Month)
        wbname = Year & "年" & CStr(Month) & "月.xlsx"
        wb.SaveAs "d:\" & wbname
        Workbooks(wbname).Close (True)
    Next
    
End Sub

Sub AddExcels2099()
    Dim Year As Integer

    Application.DisplayAlerts = False
    For Year = 2016 To 2099
        AddExcels (CStr(Year))
    Next
    Workbooks(ActiveWorkbook.Name).Close (False)
    Application.DisplayAlerts = True

End Sub