擅长使用VBA在日历中inputdate

我正在努力做什么; 我想要一个日历，当约会完成后，我可以把约会加在我的约会收取的金额作为收入，也可以添加当我购买物品，我购买他们的日子和多less，并把它作为开支。 然后，将这些信息（收入/费用）填充到另一个可以打印出来并纳入会计核算的标签中。

我正在日历部分工作，但是出现在正确的列中的日子的问题。 我每天都有3个专栏，这样我就可以稍后添加数据。 我可以在日历中填写date，但是我需要他们每次跳过两列，但他们不是。

我包括代码和这个时候出现的一个片段。

Sub CreateCalendar() Dim csheet As Worksheet Set csheet = ThisWorkbook.Sheets("Sheet2") selDate = [b1] fMon = DateSerial(Year(selDate), Month(selDate), 1) lMon = CDate(Application.WorksheetFunction.EoMonth(fMon, 0)) stRow = 4 'clear last cal Rows(4).ClearContents Rows(10).ClearContents Rows(16).ClearContents Rows(22).ClearContents Rows(28).ClearContents Rows(34).ClearContents 'determine what weekday 1st is. . . If Weekday(fMon) = 1 Then stCol = 4 ElseIf Weekday(fMon) = 4 Then stCol = 7 ElseIf Weekday(fMon) = 7 Then stCol = 10 ElseIf Weekday(fMon) = 10 Then stCol = 13 ElseIf Weekday(fMon) = 13 Then stCol = 16 ElseIf Weekday(fMon) = 16 Then stCol = 19 ElseIf Weekday(fMon) = 19 Then stCol = 22 End If For x = 1 To Day(lMon) If FirstT = Empty Then csheet.Cells(stRow, stCol) = fMon FirstT = 1 Else fMon = fMon + 1 csheet.Cells(stRow, stCol) = fMon End If If stCol = 22 Then stCol = 4 stRow = stRow + 8 Else stCol = stCol + 1 End If Next x End Sub 

日历

Answer 1

我修改了你的代码，我相信它可以正常工作。 注：（1）我对testingdate进行了硬编码; 您需要将其更改回来（2）您的代码每6行“ClearContents”不同于您的代码，以增加8行。 我设置了6行。 （3）您可以删除我在第一行放置date名称的位置。

 Option Explicit Sub CreateCalendar() Dim csheet As Worksheet Dim selDate As Date Dim fMon As Long Dim lMon As Long Dim stRow As Integer Dim stCol As Integer Dim FirstT As Integer Dim x As Integer Dim iColOffset As Integer Set csheet = ThisWorkbook.Sheets("Sheet2") selDate = #1/1/2017# '[b1] fMon = DateSerial(Year(selDate), Month(selDate), 1) lMon = CDate(Application.WorksheetFunction.EoMonth(fMon, 0)) iColOffset = 4 ' Set default starting column 'I added the following code so I could keep track... you can delete Cells(1, iColOffset) = "Sunday" Cells(1, iColOffset + 3) = "Monday" Cells(1, iColOffset + 6) = "Tuesday" Cells(1, iColOffset + 9) = "Wednesday" Cells(1, iColOffset + 12) = "Thursday" Cells(1, iColOffset + 15) = "Friday" Cells(1, iColOffset + 18) = "Saturday" stRow = 4 ' Starting Row 'clear last cal Rows(4).ClearContents Rows(10).ClearContents Rows(16).ClearContents Rows(22).ClearContents Rows(28).ClearContents Rows(34).ClearContents 'determine what weekday 1st is. . . Debug.Print "First DOW = " & Weekday(fMon) stCol = Weekday(fMon) ' Set starting column ' If Weekday(fMon) = 1 Then ' stCol = 1 ' ElseIf Weekday(fMon) = 2 Then ' stCol = 2 ' ElseIf Weekday(fMon) = 3 Then ' stCol = 3 ' ElseIf Weekday(fMon) = 10 Then ' stCol = 4 ' ElseIf Weekday(fMon) = 13 Then ' stCol = 5 ' ElseIf Weekday(fMon) = 16 Then ' stCol = 6 ' ElseIf Weekday(fMon) = 19 Then ' stCol = 7 ' End If For x = 1 To Day(lMon) If FirstT = Empty Then csheet.Cells(stRow, iColOffset + (stCol * 3) - 3) = Day(CDate(fMon)) FirstT = 1 Else fMon = fMon + 1 csheet.Cells(stRow, iColOffset + (stCol * 3) - 3) = Day(CDate(fMon)) End If 'Debug.Print iColOffset + (stCol * 3) - 3 If iColOffset + (stCol * 3) - 3 = 22 Then stCol = 1 ' *** NOTE!! Your code doesn't match. ' Above, you clear every 6 Rows (4, 10, 16, 22...), but here you are incrementing by 8. ' Which is it? 'stRow = stRow + 8 stRow = stRow + 6 ' I changed to 6 to match what you clear Else stCol = stCol + 1 End If Next x End Sub