VBA中的日历

Question

我在创建一个VBA应用程序，它会询问用户开始日期和结束日期，然后在Excel表格中输出每月日历。

在这里，我这个月在Excel工作表

enter code here 

Sub CalendarMaker() 
ActiveSheet.Protect DrawingObjects:=False, Contents:=False, _ 
Scenarios:=False 
Application.ScreenUpdating = False 
On Error GoTo MyErrorTrap 
Range("a1:g14").Clear 
MyInput = InputBox("Type in Month and year for Calendar ") 
If MyInput = "" Then Exit Sub 
StartDay = DateValue(MyInput) 
If Day(StartDay) <> 1 Then 
StartDay = DateValue(Month(StartDay) & "/1/" & _ 
Year(StartDay)) 
End If 
Range("a1").NumberFormat = "mmmm yyyy" 
With Range("a1:g1") 
.HorizontalAlignment = xlCenterAcrossSelection 
.VerticalAlignment = xlCenter 
.Font.Size = 18 
.Font.Bold = True 
.RowHeight = 35 
End With 
With Range("a2:g2") 
.ColumnWidth = 11 
.VerticalAlignment = xlCenter 
.HorizontalAlignment = xlCenter 
.VerticalAlignment = xlCenter 
.Orientation = xlHorizontal 
.Font.Size = 12 
.Font.Bold = True 
.RowHeight = 20 
End With 
Range("a2") = "Sunday" 
Range("b2") = "Monday" 
Range("c2") = "Tuesday" 
Range("d2") = "Wednesday" 
Range("e2") = "Thursday" 
Range("f2") = "Friday" 
Range("g2") = "Saturday" 
With Range("a3:g8") 
.HorizontalAlignment = xlRight 
.VerticalAlignment = xlTop 
.Font.Size = 18 
.Font.Bold = True 
.RowHeight = 21 
End With 
Range("a1").Value = Application.Text(MyInput, "mmmm yyyy") 
DayofWeek = Weekday(StartDay) 
CurYear = Year(StartDay) 
CurMonth = Month(StartDay) 
FinalDay = DateSerial(CurYear, CurMonth + 1, 1) 
Select Case DayofWeek 
Case 1 
Range("a3").Value = 1 
Case 2 
Range("b3").Value = 1 
Case 3 
Range("c3").Value = 1 
Case 4 
Range("d3").Value = 1 
Case 5 
Range("e3").Value = 1 
Case 6 
Range("f3").Value = 1 
Case 7 
Range("g3").Value = 1 
End Select 
For Each cell In Range("a3:g8") 
RowCell = cell.Row 
ColCell = cell.Column 
If cell.Column = 1 And cell.Row = 3 Then 
ElseIf cell.Column <> 1 Then 
If cell.Offset(0, -1).Value >= 1 Then 
cell.Value = cell.Offset(0, -1).Value + 1 
If cell.Value > (FinalDay - StartDay) Then 
cell.Value = "" 
Exit For 
End If 
End If 
ElseIf cell.Row > 3 And cell.Column = 1 Then 
cell.Value = cell.Offset(-1, 6).Value + 1 
If cell.Value > (FinalDay - StartDay) Then 
cell.Value = "" 
Exit For 
End If 
End If 
Next 
For x = 0 To 5 
Range("A4").Offset(x * 2, 0).EntireRow.Insert 
With Range("A4:G4").Offset(x * 2, 0) 
.RowHeight = 65 
.HorizontalAlignment = xlCenter 
.VerticalAlignment = xlTop 
.WrapText = True 
.Font.Size = 10 
.Font.Bold = False 
.Locked = False 
End With 
With Range("A3").Offset(x * 2, 0).Resize(2, _ 
7).Borders(xlLeft) 
.Weight = xlThick 
.ColorIndex = xlAutomatic 
End With 
With Range("A3").Offset(x * 2, 0).Resize(2, _ 
7).Borders(xlRight) 
.Weight = xlThick 
.ColorIndex = xlAutomatic 
End With 
Range("A3").Offset(x * 2, 0).Resize(2, 7).BorderAround _ 
Weight:=xlThick, ColorIndex:=xlAutomatic 
Next 
If Range("A13").Value = "" Then Range("A13").Offset(0, 0) _ 
.Resize(2, 8).EntireRow.Delete 
ActiveWindow.DisplayGridlines = False 
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, _ 
Scenarios:=True 
ActiveWindow.WindowState = xlMaximized 
ActiveWindow.ScrollRow = 1 
Application.ScreenUpdating = True 
Exit Sub 
MyErrorTrap: 
MsgBox "You may not have entered your Month and Year correctly." _ 
& Chr(13) & "Spell the Month correctly" _ 
& " (or use 3 letter abbreviation)" _ 
& Chr(13) & "and 4 digits for the Year" 
MyInput = InputBox("Type in Month and year for Calendar") 
If MyInput = "" Then Exit Sub 
Resume 
End Sub 

enter code here 

，要求月和一年的用户，然后输出代码，但是这个代码只为一个在一个Excel工作表中指定月创建日历，

，但我想对输入数个月，然后在VBA应在不同的输出几个月练成提前一个月在张他们每个人。

我尝试创建while循环，这整个代码输出到不同的Excel表格，但没有成功。

这里是excel的

Answer 1

一些截图，你可以这样开始：

Sub CreateCalendar(StartDate As Integer, EndDate As Integer) 
    Dim cRow As Byte, cCol As Byte 
    cRow = Day(StartDate) 
    cCol = 1 
    For StartDate = StartDate To EndDate 
    Cells(cRow, cCol).Value = StartDate 
    'change active cell with "Cells(cRow, cCol)" like format or whatever 
    If Month(StartDate) = Month(StartDate + 1) Then 
     cRow = cRow + 1 
     'same month but next day -> next row - increase "+ 1" if you ned more rows 
    Else 'new month 
     cRow = 1 'change to first row 
     cCol = cCol + 1 
     'next column - increase "+ 1" if you ned more 
    End If 
    Next 
End Sub 

编辑： 根据您编辑的问题，试试这个：

Sub SetBord(bRng As Range) 'saves space in CreateCalendar cus its always the same pattern 
    Dim x As Byte 
    For x = 7 To 10 
    bRng.Borders(x).LineStyle = 1 
    bRng.Borders(x).ColorIndex = 0 
    bRng.Borders(x).TintAndShade = 0 
    bRng.Borders(x).Weight = -4138 
    Next 
End Sub 

Sub CreateCalendar(StartDate As Long, Optional EndDate As Long) 
    'check for input errors 
    If StartDate < 1 Or EndDate < 0 Or StartDate > 2958465 Or EndDate > 2958465 Then 
    MsgBox "Dates are out of range!" 
    Exit Sub 
     'if StartDate is after EndDate you still will get at least the first month 
     'however, if you want, you can activate the next 3 lines 
    'ElseIf EndDate > 0 And EndDate < StartDate Then 
    'MsgBox "If EndDate is set, it needs to be after StartDate" 
    'Exit Sub 
    ElseIf (EndDate - StartDate) > 400 Then 
    If MsgBox("Warning: Creating a calendar for a range of " & EndDate - StartDate & " days! Are You sure?", 4) = 7 Then Exit Sub 
    End If 
    Dim cRow As Long, cCol As Byte, x As Byte 'set variables 
    StartDate = StartDate - Day(StartDate) + 1 'always create full months 
    cRow = 1 
    Do 
    With Range(Cells(cRow, 1), Cells(cRow, 7)) 'month header 
     .HorizontalAlignment = -4108 
     .MergeCells = True 
     .NumberFormat = "@" 
     .Value = Format(StartDate, "MMMM yyyy") 
    End With 
    SetBord Range(Cells(cRow, 1), Cells(cRow, 7)) 
    cRow = cRow + 1 
    For x = 1 To 7 'weekday header 
     With Cells(cRow, x) 
     .HorizontalAlignment = -4108 
     .NumberFormat = "@" 
     .Value = Format(x, "dddd") 
     End With 
    Next 
    For x = 1 To 7 Step 2 'set all borders 
     SetBord Range(Cells(cRow, x), Cells(cRow + 24, x)) 
    Next 
    SetBord Range(Cells(cRow, 1), Cells(cRow, 7)) 
    cRow = cRow + 1 
    For x = 4 To 20 Step 4 
     SetBord Range(Cells(cRow + x, 1), Cells(cRow + x + 3, 7)) 
    Next 
    cCol = (StartDate - 1) Mod 7 + 1 
    Do 'set day numbers 
     Cells(cRow, cCol).Value = Day(StartDate) 
     StartDate = StartDate + 1 
     If cCol = 7 Then 
     cCol = 1 
     cRow = cRow + 4 
     Else 
     cCol = cCol + 1 
     End If 
    Loop While Month(StartDate) = Month(StartDate - 1) 
    cRow = cRow - ((cRow - 1) Mod 27) + 27 
    Loop While EndDate > StartDate 
End Sub 

注意：所有月份都有相同的6周高度 至少我把字体留给你：D