Excel VBA日历修改无法永久保存的解决方法问询

问题根源 #

你的代码每次生成新日历前都会执行Range("a1:g14").Clear，直接清空日历区域的所有内容，包括用户输入的标记信息。切换月份再返回时，新生成的日历是空白状态，自然看不到之前的修改。

解决方案 #

添加一个隐藏工作表作为数据存储区，专门保存每个日期对应的备注内容。生成日历前读取存储的数据，生成后将对应日期的备注回填；同时监听备注单元格的修改，实时更新存储区的数据，实现修改永久保存。

修改后的完整代码 #

Sub CalendarMaker()
    Dim ws As Worksheet, dataWs As Worksheet
    Dim MyInput As String, StartDay As Date
    Dim DayofWeek As Integer, CurYear As Integer, CurMonth As Integer
    Dim FinalDay As Date, cell As Range
    Dim x As Integer, targetDate As Date
    Dim foundRow As Range
    
    ' 设置当前工作表和数据存储表
    Set ws = ActiveSheet
    On Error Resume Next
    Set dataWs = ThisWorkbook.Worksheets("CalendarData")
    On Error GoTo 0
    
    ' 如果数据存储表不存在，创建并隐藏它
    If dataWs Is Nothing Then
        Set dataWs = ThisWorkbook.Worksheets.Add(After:=ws)
        dataWs.Name = "CalendarData"
        ' 设置表头
        dataWs.Range("A1") = "日期"
        dataWs.Range("B1") = "备注"
        dataWs.Columns("A").NumberFormat = "yyyy-mm-dd"
        dataWs.Columns("B").ColumnWidth = 50
        dataWs.Visible = xlSheetVeryHidden ' 隐藏工作表，防止误编辑
    End If
    
    ' 解除工作表保护
    ws.Protect DrawingObjects:=False, Contents:=False, Scenarios:=False
    Application.ScreenUpdating = False
    On Error GoTo MyErrorTrap
    
    ' 只清空日期和备注区域，保留表头避免重复创建
    ws.Range("A3:G" & ws.Cells(ws.Rows.Count, "A").End(xlUp).Row).Clear
    
    ' 获取用户输入的年月
    MyInput = InputBox("请输入日历的月份和年份（例如：2023年1月 或 Jan 2023）")
    If MyInput = "" Then Exit Sub
    StartDay = DateValue(MyInput)
    If Day(StartDay) <> 1 Then
        StartDay = DateValue(Month(StartDay) & "/1/" & Year(StartDay))
    End If
    
    ' 处理表头（如果是第一次生成或表头被意外清空）
    If ws.Range("A1").Value = "" Then
        ws.Range("a1").NumberFormat = "mmmm yyyy"
        With ws.Range("a1:g1")
            .HorizontalAlignment = xlCenterAcrossSelection
            .VerticalAlignment = xlCenter
            .Font.Size = 18
            .Font.Bold = True
            .RowHeight = 35
        End With
        With ws.Range("a2:g2")
            .ColumnWidth = 11
            .VerticalAlignment = xlCenter
            .HorizontalAlignment = xlCenter
            .Font.Size = 12
            .Font.Bold = True
            .RowHeight = 20
        End With
        ws.Range("a2") = "星期日"
        ws.Range("b2") = "星期一"
        ws.Range("c2") = "星期二"
        ws.Range("d2") = "星期三"
        ws.Range("e2") = "星期四"
        ws.Range("f2") = "星期五"
        ws.Range("g2") = "星期六"
    End If
    
    ' 设置年月标题
    ws.Range("a1").Value = Application.Text(MyInput, "yyyy年mm月")
    
    ' 生成日期单元格格式
    With ws.Range("a3:g8")
        .HorizontalAlignment = xlRight
        .VerticalAlignment = xlTop
        .Font.Size = 18
        .Font.Bold = True
        .RowHeight = 21
    End With
    
    DayofWeek = Weekday(StartDay)
    CurYear = Year(StartDay)
    CurMonth = Month(StartDay)
    FinalDay = DateSerial(CurYear, CurMonth + 1, 1)
    
    ' 放置当月第一天
    Select Case DayofWeek
        Case 1: ws.Range("a3").Value = 1
        Case 2: ws.Range("b3").Value = 1
        Case 3: ws.Range("c3").Value = 1
        Case 4: ws.Range("d3").Value = 1
        Case 5: ws.Range("e3").Value = 1
        Case 6: ws.Range("f3").Value = 1
        Case 7: ws.Range("g3").Value = 1
    End Select
    
    ' 填充当月剩余日期
    For Each cell In ws.Range("a3:g8")
        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
    
    ' 创建备注单元格（如果不存在）
    If ws.Range("A4").RowHeight <> 65 Then
        For x = 0 To 5
            ws.Range("A4").Offset(x * 2, 0).EntireRow.Insert
            With ws.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 ws.Range("A3").Offset(x * 2, 0).Resize(2, 7).Borders(xlLeft)
                .Weight = xlThick
                .ColorIndex = xlAutomatic
            End With
            With ws.Range("A3").Offset(x * 2, 0).Resize(2, 7).Borders(xlRight)
                .Weight = xlThick
                .ColorIndex = xlAutomatic
            End With
            ws.Range("A3").Offset(x * 2, 0).Resize(2, 7).BorderAround Weight:=xlThick, ColorIndex:=xlAutomatic
        Next
        If ws.Range("A13").Value = "" Then ws.Range("A13").Resize(2, 8).EntireRow.Delete
    End If
    
    ' 回填已保存的备注内容
    For Each cell In ws.Range("a3:g8")
        If cell.Value <> "" Then
            targetDate = DateSerial(CurYear, CurMonth, cell.Value)
            ' 在数据存储表中查找对应的日期
            Set foundRow = dataWs.Columns("A").Find(What:=targetDate, LookIn:=xlValues, LookAt:=xlWhole)
            If Not foundRow Is Nothing Then
                ' 备注单元格在日期单元格的下一行
                cell.Offset(1, 0).Value = foundRow.Offset(0, 1).Value
            End If
        End If
    Next
    
    ' 设置工作表保护，允许编辑备注单元格
    ws.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, UserInterfaceOnly:=True
    ' UserInterfaceOnly:=True 允许VBA代码修改受保护的工作表
    
    ' 显示日历
    ActiveWindow.DisplayGridlines = False
    ActiveWindow.WindowState = xlMaximized
    ActiveWindow.ScrollRow = 1
    Application.ScreenUpdating = True
    
    Exit Sub
    
MyErrorTrap:
    MsgBox "你输入的月份或年份格式不正确，请重新输入。" & Chr(13) & "示例：2023年1月 或 Jan 2023"
    MyInput = InputBox("请输入日历的月份和年份")
    If MyInput = "" Then Exit Sub
    Resume
End Sub

' 监听备注单元格的修改，实时保存到数据存储表
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim dataWs As Worksheet
    Dim targetDate As Date
    Dim dateCell As Range
    Dim foundRow As Range
    
    ' 只处理备注单元格（日期单元格下一行的区域）
    If Not Intersect(Target, Me.Range("A4:G14")) Is Nothing And Target.Count = 1 Then
        ' 获取对应的日期单元格
        Set dateCell = Target.Offset(-1, 0)
        If dateCell.Value <> "" And IsNumeric(dateCell.Value) Then
            ' 构建完整日期
            targetDate = DateSerial(Year(DateValue(Me.Range("A1").Value)), _
                                  Month(DateValue(Me.Range("A1").Value)), _
                                  dateCell.Value)
            
            ' 找到数据存储表
            On Error Resume Next
            Set dataWs = ThisWorkbook.Worksheets("CalendarData")
            On Error GoTo 0
            
            If Not dataWs Is Nothing Then
                ' 查找是否已有该日期的记录
                Set foundRow = dataWs.Columns("A").Find(What:=targetDate, LookIn:=xlValues, LookAt:=xlWhole)
                Application.EnableEvents = False ' 禁用事件防止循环触发
                
                If Not foundRow Is Nothing Then
                    ' 更新现有记录
                    foundRow.Offset(0, 1).Value = Target.Value
                Else
                    ' 添加新记录
                    Set foundRow = dataWs.Cells(dataWs.Rows.Count, "A").End(xlUp).Offset(1, 0)
                    foundRow.Value = targetDate
                    foundRow.Offset(0, 1).Value = Target.Value
                End If
                
                Application.EnableEvents = True ' 重新启用事件
            End If
        End If
    End If
End Sub

使用说明 #

1. 打开Excel，按Alt+F11打开VBA编辑器。
2. 在当前工作表的代码窗口中，粘贴上述代码（包括CalendarMaker和Worksheet_Change两个过程）。
3. 返回Excel，运行CalendarMaker宏生成日历。
4. 在日期下方的备注单元格输入内容，修改会自动保存到隐藏的"CalendarData"工作表。
5. 切换月份再返回时，对应日期的备注会自动加载显示。

关键改进点 #

• 新增隐藏工作表存储日期和备注，实现数据持久化。
• 修改清空逻辑，保留表头区域，避免重复创建格式。
• 添加Worksheet_Change事件监听，实时保存用户修改。
• 优化工作表保护设置，允许用户编辑备注单元格同时保护日历结构。

内容的提问来源于stack exchange，提问作者eduardoaa