VBA 操作 Excel 生成日期及星期

最新推荐文章于 2025-02-10 00:49:32 发布

转载最新推荐文章于 2025-02-10 00:49:32 发布 · 1.6k 阅读

6 ·

CC 4.0 BY-SA版权

原文链接：http://www.cnblogs.com/lovesqcc/p/5558594.html

本文介绍使用VBA脚本自动生成包含指定月份每一天及其对应星期的Excel表格的方法，并提供了生成从当前年至2099年所有月份日期的示例代码。

摘要生成于 C知道，由 DeepSeek-R1 满血版支持，前往体验 >

直接上代码~~

1. 在一个 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

2. 生成直到2099年的日期及月份，每个月份一个 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(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

小记：

(1) 函数返回值，使用函数名作为变量在最后一行赋值；

(2) 调用过程： CALL SubName(ArgList) ；

(3) 变量名、函数名习惯大写；

(4) Switch , If, For , Sub, Function 定义代码里有；

(5) 整数转字符串 CStr, 字符串转整数 CInt ；字符串连接 & ;

(6) 当前活动工作表 ActiveSheet , 当前活动工作簿： ActiveWorkBook ;

(7) 操作当前活动工作表： ActiveSheet.Name, ActiveSheet.[CellID].Value ; ActiveSheet.[A1].Columns, ActiveSheet.[A1].Rows 行列设置；

(8) 工作簿操作：新增 Set wb = Workbooks.Add ; 保存 wb SaveAs "Path/file.xlsx" ; 关闭 Workbooks(wbname).Close (True) .

无论怎样的编程语言，函数或过程复用是最基本的技能；

只要是在计算设备上， 99%的人工操作均可自动化。

转载于:https://www.cnblogs.com/lovesqcc/p/5558594.html