直接上程式碼~~

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