VBA需求：按周检查任务完成状态并批量更新单元格值

需求概述 #

需检查每月中每周的任务完成状态，D列为日期列，Y列为任务状态列。若某周内Y列存在"Complete"，则跳过该周；若不存在（为空白或"Not Applicable"），需将该周周五对应的Y列单元格设为"Incomplete"，其余日期的Y列设为"Not Applicable"。

问题描述 #

用户编写的VBA宏执行后无效果：空白单元格仍为空白，整周均显示"Not Applicable"，代码如下：

Sub onceaweek()

Dim ws As Worksheet
Dim lastRow As Long
Dim currentDate As Date
Dim currentWeek As Integer
Dim rng As Range
Dim cell As Range
Dim completeFound As Boolean
Dim i As Long

Set ws = ThisWorkbook.Sheets("rawday")
lastRow = ws.Cells(ws.Rows.Count, "D").End(xlUp).Row

For i = lastRow To 2 Step -1
    
    currentDate = ws.Cells(i, 4).Value
    currentWeek = WorksheetFunction.WeekNum(currentDate, vbMonday)

    Set rng = ws.Range("Y" & i & ":Y" & WorksheetFunction.Match(WorksheetFunction.WorkDay(currentDate, 6), ws.Columns(4), 1))

    completeFound = False
    For Each cell In rng
        If cell.Value = "Complete" Then
            completeFound = True
            Exit For
        End If
    Next cell
    If Not completeFound Then
        ws.Cells(i, 25).Value = "Incomplete"
        rng.Offset(0, 1).Resize(, rng.Columns.Count - 1).Value = "Not Applicable"
    End If
Next i
End Sub

问题排查 #

1. 周范围选取错误

   • WorkDay(currentDate,6)是往后推6个工作日，不一定是当周周五（若有节假日），且Match用参数1（近似匹配），日期列不连续或非严格升序时会匹配错误。
   • 从下往上遍历会重复处理同一周的多行，导致逻辑混乱。

2. 赋值逻辑错误

   • rng.Offset(0,1)将内容写入Y列右侧的Z列，而非Y列的其他行，完全偏离需求。
   • Resize(, rng.Columns.Count -1)调整的是列数，而非覆盖整周Y列的行数。

3. 重复周处理
   同一周的每一行都会触发一次处理，导致之前的修改被覆盖，最终整周都被设为"Not Applicable"。

修复后的代码 #

Sub UpdateWeeklyTaskStatus()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim currentDate As Date
    Dim weekStart As Date
    Dim weekEnd As Date ' 当周周五
    Dim weekRange As Range
    Dim completeFound As Boolean
    Dim cell As Range
    Dim processedWeeks As Collection
    
    Set ws = ThisWorkbook.Sheets("rawday")
    lastRow = ws.Cells(ws.Rows.Count, "D").End(xlUp).Row
    Set processedWeeks = New Collection ' 记录已处理的周，避免重复操作
    
    For i = 2 To lastRow
        currentDate = ws.Cells(i, "D").Value
        ' 计算当周起始（周一）和结束（周五）
        weekStart = DateAdd("d", -Weekday(currentDate, vbMonday) + 1, currentDate)
        weekEnd = DateAdd("d", 4, weekStart) ' 周一加4天是周五
        
        ' 检查该周是否已处理过
        On Error Resume Next
        processedWeeks.Add weekStart, Key:=CStr(weekStart)
        On Error GoTo 0
        If Err.Number <> 0 Then
            Err.Clear
            GoTo NextRow ' 已处理过，跳过当前行
        End If
        
        ' 定位当周所有日期对应的行范围（D列）
        Dim firstRow As Long, lastWeekRow As Long
        On Error Resume Next
        firstRow = WorksheetFunction.Match(weekStart, ws.Columns("D"), 0)
        lastWeekRow = WorksheetFunction.Match(weekEnd, ws.Columns("D"), 0)
        On Error GoTo 0
        
        ' 如果找不到周五的行，取周内最后一个存在的日期行
        If lastWeekRow = 0 Then
            lastWeekRow = ws.Columns("D").Find(What:=weekEnd, LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlPrevious).Row
        End If
        
        Set weekRange = ws.Range("Y" & firstRow & ":Y" & lastWeekRow)
        
        ' 检查该周是否存在"Complete"（不区分大小写）
        completeFound = False
        For Each cell In weekRange
            If UCase(cell.Value) = "COMPLETE" Then
                completeFound = True
                Exit For
            End If
        Next cell
        
        ' 按需求更新状态
        If Not completeFound Then
            ' 先将整周Y列设为"Not Applicable"
            weekRange.Value = "Not Applicable"
            ' 找到周五对应的单元格，设为"Incomplete"
            Dim fridayCell As Range
            On Error Resume Next
            Set fridayCell = ws.Columns("D").Find(What:=weekEnd, LookIn:=xlValues, LookAt:=xlWhole)
            On Error GoTo 0
            If Not fridayCell Is Nothing Then
                ws.Cells(fridayCell.Row, "Y").Value = "Incomplete"
            Else
                ' 如果没有周五的行，将周内最后一行设为"Incomplete"
                ws.Cells(lastWeekRow, "Y").Value = "Incomplete"
            End If
        End If
        
NextRow:
    Next i
End Sub

修复说明 #

• 用Collection记录已处理的周，避免重复操作同一周的多行。
• 正确计算当周的周一和周五，确保周范围准确。
• 先将整周Y列设为"Not Applicable"，再将周五（或周内最后一行）设为"Incomplete"，完全符合需求逻辑。
• 增加错误处理，应对日期列缺失周五的情况。
• 使用不区分大小写的匹配，避免因大小写差异导致漏判。

内容的提问来源于stack exchange，提问作者Rebecca S.