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应该在不同的Excel工作表中输出几个月，每个工作表一个月。

我尝试创建一个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

VBA中的日历

1 个答案: