VBA 操作 Excel 生成日期及星期

     

     直接上代碼~~

     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%的人工操作均可自動化。