Question

我想做什么; 我想要一个我可以预约的日历，然后在预约完成后添加我预约收取的金额作为收入，也可以在我购买物品时添加到我买的那天以及多少并将其作为费用。然后将这些信息（收入/支出）填入另一个标签中，该标签可以打印出来并交给会计师进行纳税。

我正在处理日历部分，但是出现在正确列中的日期有问题。我每天有3个列，所以我以后可以添加数据。我可以在日历中填写日期，但我需要它们每次跳过两列，但它们不是。

我正在包含代码以及此时它是如何发布的剪辑。

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

Calendar

Answer 1

我修改了你的代码，我相信它可以按你的意愿运行。注意：（1）我硬编码测试日期;你需要改回来（2）您的代码为＆＃39; ClearContents＆＃39;每6行与您的代码不同，增加8行。我设置为6行。（3）你可以删除我在第一行放置日期名称的位置。

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

excel使用VBA在日历中输入日期

1 个答案: