VBA自动化活动跟踪日期：实现月份切换时自动更新日期

问题需求 #

通过VBA自动化实现活动跟踪表的日期更新：现有代码可复制前一个工作表内容，但无法实现从六月依次更新至七月、八月直到十二月，需要实现每次切换月份时自动更新对应日期。

现有代码 #

Sub CopierTableau()
    Dim i As Integer
    Dim mois As Integer
    Dim annee As Integer
    Dim MoisActuel As String
    Dim lastRow As Long
    Dim currentDate As Date
    Dim MyWeekDay As Integer
    
    mois = Month(Date)
    annee = Year(Date)
    
    For i = mois + 1 To 12
        MoisActuel = MonthName(i)
        lastRow = Sheets(MoisActuel).Cells(Rows.Count, 1).End(xlUp).Row
        Sheets(MoisActuel).Range("A1:GP" & lastRow).Copy Destination:=Sheets(i).Range("A1")
        ChangerDates i
    Next i
End Sub

Sub ChangerDates(i As Integer)
    Dim Rng As Range
    Dim cell As Range
    
    Set Rng = Sheets(i).Range("B1:FN1")
        
    For Each cell In Rng
        If IsDate(cell.Value) Then
            If Month(cell.Value) = i Then
                cell.Value = DateAdd("m", 1, cell.Value)
                cell.Value = DateSerial(Year(cell.Value), Month(cell.Value), Day(cell.Value))
            End If
        End If
    Next
End Sub

代码问题分析 #

1. 工作表引用错误：Sheets(i)使用数字索引引用工作表，但工作表名称是月份名称（如"七月"），数字索引大概率不匹配，导致复制和修改操作指向错误工作表。
2. 日期判断逻辑错误：ChangerDates中判断Month(cell.Value) = i，但复制的是前一个月的工作表内容，日期应为i-1月，此条件无法匹配目标日期，导致日期未更新。

修改后的代码 #

Sub CopierTableau()
    Dim i As Integer
    Dim mois As Integer
    Dim MoisPrecedent As String
    Dim MoisActuel As String
    Dim lastRow As Long
    
    mois = Month(Date)
    
    ' 从当前下一个月循环到12月
    For i = mois + 1 To 12
        MoisActuel = MonthName(i)
        MoisPrecedent = MonthName(i - 1) ' 取前一个月的工作表名称
        
        ' 复制前一个月工作表的全部内容到当前月份工作表
        lastRow = Sheets(MoisPrecedent).Cells(Rows.Count, 1).End(xlUp).Row
        Sheets(MoisPrecedent).Range("A1:GP" & lastRow).Copy Destination:=Sheets(MoisActuel).Range("A1")
        
        ' 更新当前月份工作表的日期
        ChangerDates MoisActuel, i
    Next i
End Sub

Sub ChangerDates(wsName As String, targetMonth As Integer)
    Dim Rng As Range
    Dim cell As Range
    
    ' 定位需要更新日期的行范围
    Set Rng = Sheets(wsName).Range("B1:FN1")
        
    For Each cell In Rng
        If IsDate(cell.Value) Then
            ' 将前一个月的日期加1个月，更新为目标月份的日期
            cell.Value = DateAdd("m", 1, cell.Value)
            ' 确保日期格式正确（自动处理月末日期，如2月28/29日）
            cell.Value = DateSerial(Year(cell.Value), Month(cell.Value), Day(cell.Value))
        End If
    Next
End Sub

关键修改说明 #

• 修正工作表引用：通过MonthName(i-1)获取前一个月的工作表名称，确保复制源正确；修改ChangerDates接收工作表名称参数，精准定位目标工作表。
• 简化日期更新逻辑：去掉错误的月份判断，直接对所有日期单元格执行DateAdd("m", 1, cell.Value)，将前一个月的日期自动加1个月，同时DateSerial会自动处理月末的无效日期（如3月31日加1个月变为4月30日）。
• 优化循环逻辑：明确复制源为前一个月的工作表，避免原代码中复制当前月份自身内容的逻辑错误。

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