excel - 问题制作日历

Question

我在 VBA 中遇到了日历问题。想要创建一个日历，根据 A22 和 B22 列中输入的日期显示/绘制从 2022 年开始的周数范围。当周数在几个月之间重复时，就会出现问题。

Tydzien = Week
Sty = January 
Lut = February

Option Explicit

Sub Kolorowaniedaty()
    Dim rok As Integer
        rok = Left(Cells(22, 2), 4)
    
    Dim miesiacpocz As Integer
        miesiacpocz = Mid(Cells(22, 2), 7, 1)
    
    Dim miesiackon As Integer
        miesiackon = Mid(Cells(22, 3), 7, 1)    
    
    Dim Datapocz As Integer
        Datapocz = Application.WorksheetFunction.WeekNum(Cells(22, 2), 2)    
    
    Dim Datakon As Integer
        Datakon = Application.WorksheetFunction.WeekNum(Cells(22, 3), 2)
    
    Dim Rokzdaty As String
        Rokzdaty = CStr(Mid(Cells(22, 2), 3, 2))
    
    Dim Rok2022 As Byte
        Rok2022 = 22
       
    Dim kolumna As Byte       
    
    For kolumna = 1 To 20
    
    If Rokzdaty = Rok2022 And miesiacpocz = miesiackon Then
       Range(Cells(22, Datapocz + 4), Cells(22, Datakon + 4)).Interior.Color = vbYellow
       Else: Range(Cells(22, Datapocz + 4), Cells(22, Datakon + 5)).Interior.Color = vbYellow
    
    End If
    
    Next kolumna
End Sub

我无法从 excel 上传 Makro 和日历的图像，因为我没有足够的声誉点。如果有人可以通过私有(private)聊天提供帮助，我将非常感激。它必须来自我的工作。
[![在此处输入图像描述][3]][3]
它应该标记 11 周，但它的节目只有 10 周。有什么建议吗？
[3]: /image/X8kwQ.png

Answer 1

迭代日期范围内的每一天，并在每个星期一或月份的变化增加列号。将列号存储在一个数组中，并将其用作查找来确定给定日期的列号。运行这是一个新的干净工作簿。
更新 - 完全重写

Option Explicit
Const START_COL = 4
Const START_ROW = 22
Const MAX_YEARS = 4
Const START_YEAR = 2022
    
Sub CalendarDemo()

    Dim ws As Worksheet
    Dim dt As Date, dtDay1 As Date
    Dim wkno As Long, dayno As Long
    Dim colno As Long, i As Long, c As Long, r As Long
    
    Dim arCol, arDate
    ReDim arCol(1 To 2, 1 To MAX_YEARS * 12 * 7)
    ReDim arDate(1 To MAX_YEARS * 366, 1 To 5) ' wkno, month no, column, date, dow
    
    ' start Jan 1
    dtDay1 = DateSerial(START_YEAR, 1, 1)
    colno = 1
    wkno = 1
    i = 1
    
    ' iterate through days built look up array
    dt = dtDay1
    Do While Year(dt) < START_YEAR + MAX_YEARS
        
        arDate(i, 2) = Month(dt)
        arDate(i, 5) = Weekday(dt, vbMonday)
        
        If i > 1 Then
            ' change of week or month
            If arDate(i, 5) = 1 Then
                wkno = wkno + 1
                If (wkno > 52) And (Month(dt) = 1) Then wkno = 1
                colno = colno + 1
            ElseIf arDate(i, 2) <> arDate(i - 1, 2) Then
                colno = colno + 1
            End If
        End If
        
        ' reset wkno to 1 on jan 1st
        If wkno >= 52 And arDate(i, 2) = 1 Then wkno = 1
        arDate(i, 1) = wkno
        arDate(i, 3) = colno
        arDate(i, 4) = dt
        
        ' fill arCol
        arCol(1, colno) = Format(dt, "mmm yyyy")
        arCol(2, colno) = wkno
                   
        dt = dt + 1
        i = i + 1
    Loop

    ' paint cells
    Dim lastrow As Long, dtStart As Date, dtEnd As Date
    Dim colStart As Long, colEnd As Long, n As Long, m As Long
    
    Set ws = Sheets(1)
    Call testdata(ws)

    With ws
        lastrow = .Cells(.Rows.Count, "B").End(xlUp).Row
        For r = START_ROW To lastrow
        
            ' check dates are valid
            dtStart = .Cells(r, "B")
            dtEnd = .Cells(r, "C")
            If dtEnd < dtStart Then
                MsgBox "End Date before Start Date on row " & r, vbCritical
                Exit Sub
            ElseIf dtStart < dtDay1 Then
                MsgBox "Start Date before 1 Jan " & START_YEAR & " on row " & r, vbCritical
                Exit Sub
            End If
            
            ' calc day number relative to day1
            m = DateDiff("d", dtDay1, dtStart, dtDay1) + 1
            n = DateDiff("d", dtDay1, dtEnd, dtDay1) + 1
            If n > UBound(arDate) Or m > UBound(arDate) Then
                MsgBox "Increase MAX_YEARS for row " & r, vbCritical
                Exit Sub
            End If
            
            ' lookup col number
            colStart = arDate(m, 3) + START_COL
            colEnd = arDate(n, 3) + START_COL
            
            ' merge and color
            With .Cells(r, colStart)
                With .Resize(1, colEnd - colStart + 1)
                    .Interior.Color = vbYellow
                    .Borders.LineStyle = xlContinuous
                    .Merge
                End With
                .Value = Space(5) & Format(dtStart, "dd mmm") & " - " & Format(dtEnd, "dd mmm yyyy")
            End With
        Next
    End With
    
    ' add headers
    Call FormatSheet(ws, arCol, arDate, colno)
    MsgBox "Generated " & colno & " Columns", vbInformation
    
End Sub

Sub FormatSheet(ws As Worksheet, arCol, arDate, colno As Long)

    Dim c As Long, i As Long, n As Long, dt As Date
    
    ' format sheet header rows
    With Sheet1
        .Rows("10:21").Clear
        .Cells.MergeCells = False
        With .Range("E20").Resize(2, colno)
            .NumberFormat = "@"
            .HorizontalAlignment = xlCenter
            .Value2 = arCol
        End With
    
        ' merge months
        i = 0
        For c = 5 To colno + 4
            If .Cells(20, c + 1) = .Cells(20, c) Then
                i = i + 1
            Else
                With .Cells(20, c - i)
                    Application.DisplayAlerts = False
                    .Resize(1, i + 1).Merge
                    Application.DisplayAlerts = True
                    .Resize(2, 1).Borders(xlLeft).LineStyle = xlContinuous
                End With
                i = 0
            End If
        Next
    End With
    
    ' calendar to check array
    For i = 1 To UBound(arDate)
        dt = arDate(i, 4) ' date
        n = arDate(i, 5) ' weekday
        If dt > 0 Then
            n = Weekday(dt, vbMonday)
            ws.Cells(10 + n, arDate(i, 3) + START_COL) = Day(dt)
        End If
        ' mon,tue,wed
        If i < 8 Then
            ws.Cells(10 + n, START_COL) = WeekdayName(n)
        End If
    Next

End Sub

Sub testdata(ws)
    With ws
    .Cells(22, 2) = "2022-01-01": .Cells(22, 3) = "2022-03-08"
    .Cells(23, 2) = "2022-02-01": .Cells(23, 3) = "2022-02-28"
    .Cells(24, 2) = "2022-03-01": .Cells(24, 3) = "2022-03-31"
    .Cells(25, 2) = "2022-03-15": .Cells(25, 3) = "2022-05-15"
    .Cells(26, 2) = "2022-03-15": .Cells(26, 3) = "2024-03-20"
    End With
End Sub