1. 功能实现目标 #

• 在「Summary」工作表的月份下拉列表（包含JAN、FEB、MAR等选项）中选择月份后，自动更新「Equipment」工作表的F7:AJ7区域为该月份的对应日期
• 同时F8:AJ8区域通过公式=IF(F7="","",TEXT(F7,"ddd"))显示对应日期的星期（Sat、Sun、Mon等）

2. 核心数据处理需求 #

• 当某列的星期头为Fri时，清空该列中F9:F及对应列区域内值为10的单元格（该区域内数据为10、空白交替排列）；需采用整列范围（如F9:F）以支持行的增删操作，且仅清空值为10的单元格，不影响打印区域外的其他内容
• 当切换月份导致「Fri」对应的列发生变化时，之前被清空的非当前「Fri」列的对应单元格需恢复为10

3. 现有实现情况 #

已完成的设置：

• 使用条件格式将「Fri」列标记为橙色，值小于10的单元格标记为红色
• 编写了以下VBA代码，但尚未完全实现需求，需要优化完善

现有Test子过程代码 #

Sub Test()
Application.ScreenUpdating = False
Dim bottomA As Integer
Dim bottomB As Integer
Dim bottomC As Integer
Dim bottomD As Integer
Dim bottomE As Integer
bottomA = Range("F" & Rows.Count).End(xlUp).Row
bottomB = Range("M" & Rows.Count).End(xlUp).Row
bottomC = Range("T" & Rows.Count).End(xlUp).Row
bottomD = Range("AA" & Rows.Count).End(xlUp).Row
bottomE = Range("AH" & Rows.Count).End(xlUp).Row
Dim rng As Range
Dim rng1 As Range
Dim rng2 As Range
Dim rng3 As Range
Dim rng4 As Range
For Each rng In Range("F9:F" & bottomA)
rng.Value = Replace(rng, 10#, "")
Next rng
'Application.ScreenUpdating = True
For Each rng1 In Range("M9:M" & bottomB)
rng1.Value = Replace(rng1, 10#, "")
Next rng1
'Application.ScreenUpdating = True
For Each rng2 In Range("T9:T" & bottomC)
rng2.Value = Replace(rng2, 10#, "")
Next rng2
'Application.ScreenUpdating = True
For Each rng3 In Range("AA9:AA" & bottomD)
rng3.Value = Replace(rng3, 10#, "")
Next rng3
'Application.ScreenUpdating = True
For Each rng4 In Range("AH9:AH" & bottomE)
rng4.Value = Replace(rng4, 10#, "")
Next rng4
'Application.ScreenUpdating = True
End Sub

候选Worksheet_Change事件代码 #

Private Sub Worksheet_Change(ByVal Target As Range)
Dim cell As Range
' Exit if multiple cells updated at once
If Target.CountLarge > 1 Then Exit Sub
' See if cell is updated in watched range
If (Not Intersect(Target, Range("F8").Value = "Fri") Is Nothing) And (Target.Value <> "") Then
Application.EnableEvents = False
' Loop through each cell in other range
For Each cell In Range("F9:F300")
' See if it matches and clear value
If cell.Value = Target.Value Then cell.ClearContents
Next cell
Application.EnableEvents = True
End If
End Sub

月份下拉列表实现代码 #

On Error Resume Next
Set xCombox = xWs.OLEObjects("TempCombo")
With xCombox
.ListFillRange = ""
.LinkedCell = ""
.Visible = False
' ******* Disable the below 2 lines if you are typing the whole sheet *******
' .Locked = True
'ActiveSheet.Protect Password:"123"
'*******************************************************************
End With
If Target.Validation.Type = 3 Then
Target.Validation.InCellDropdown = False
cancel = True
xStr = Target.Validation.Formula1
xStr = Right(xStr, Len(xStr) - 1)
If xStr = "" Then Exit Sub
With xCombox
.Visible = True
.Left = Target.Left
.Top = Target.Top
.Width = Target.Width + 5
.Height = Target.Height + 5
.ListFillRange = xStr
If .ListFillRange = "" Then
xArr = Split(xStr, ",")
Me.Tempcombo.List = xArr
End If
.LinkedCell = Target.Address
End With
xCombox.Activate
Me.Tempcombo.DropDown
Me.Tempcombo.SelStart = 0
Me.Tempcombo.SelLength = Len(Me.Tempcombo.Value)
' The below line is to unprotect the sheet
ActiveSheet.Unprotect
End If
End Sub
Private Sub TempCombo_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Select Case KeyCode
Case 9
Application.ActiveCell.Offset(0, 1).Activate
Case 13
Application.ActiveCell.Offset(1, 0).Activate
End Select
End Sub

优化后的完整解决方案 #

步骤1：完善月份选择后的日期更新逻辑 #

在「Summary」工作表的下拉列表变更事件中，添加更新「Equipment」工作表日期的代码（假设下拉列表在Summary!A1单元格）：

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Me.Range("A1")) Is Nothing Then ' 替换为你的下拉列表实际单元格地址
        Dim monthName As String
        Dim yearNum As Integer
        Dim startDate As Date
        
        ' 假设年份为当前年，可根据需求手动指定或从单元格读取
        yearNum = Year(Date)
        monthName = Target.Value
        
        ' 获取选中月份的第一天
        startDate = DateSerial(yearNum, Month(DateValue(monthName & " 1")), 1)
        
        With ThisWorkbook.Worksheets("Equipment")
            ' 清空目标日期区域
            .Range("F7:AJ7").ClearContents
            
            ' 逐列填充日期，直到该月份结束
            Dim col As Integer
            For col = 6 To 36 ' F是第6列，AJ是第36列
                If startDate <= DateSerial(yearNum, Month(startDate) + 1, 0) Then
                    .Cells(7, col).Value = startDate
                    startDate = startDate + 1
                End If
            Next col
        End With
        
        ' 触发Fri列的处理逻辑
        ProcessFriColumns
    End If
End Sub

步骤2：实现Fri列的单元格清空与恢复逻辑 #

添加通用处理过程，确保切换月份时自动恢复之前清空的单元格：

Sub ProcessFriColumns()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("Equipment")
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    ' 第一步：恢复所有符合条件的空白单元格为10（假设奇数行原本是10，可根据实际交替规则调整）
    Dim cell As Range
    For Each cell In ws.Range("F9:AJ" & ws.Rows.Count)
        If cell.Value = "" Then
            ' 判断是否为原本应该是10的行（这里以9、11、13...奇数行为例）
            If (cell.Row - 8) Mod 2 = 1 Then
                cell.Value = 10
            End If
        End If
    Next cell
    
    ' 第二步：定位当前所有Fri列，清空其中值为10的单元格
    Dim col As Integer
    For col = 6 To 36
        If ws.Cells(8, col).Value = "Fri" Then
            For Each cell In ws.Range(ws.Cells(9, col), ws.Cells(ws.Rows.Count, col))
                If cell.Value = 10 Then
                    cell.ClearContents
                End If
            Next cell
        End If
    Next col
    
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub

步骤3：下拉列表代码优化（可选） #

简化原下拉列表代码，确保和工作表事件兼容：

' 放在「Summary」工作表模块中
Dim xCombox As OLEObject

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    On Error Resume Next
    Set xCombox = Me.OLEObjects("TempCombo")
    With xCombox
        .ListFillRange = ""
        .LinkedCell = ""
        .Visible = False
    End With
    
    If Target.CountLarge <> 1 Then Exit Sub
    If Target.Validation.Type = 3 Then
        Target.Validation.InCellDropdown = False
        Dim xStr As String
        xStr = Target.Validation.Formula1
        xStr = Right(xStr, Len(xStr) - 1)
        If xStr = "" Then Exit Sub
        
        With xCombox
            .Visible = True
            .Left = Target.Left
            .Top = Target.Top
            .Width = Target.Width + 5
            .Height = Target.Height + 5
            ' 兼容逗号分隔的列表和单元格区域列表
            If InStr(xStr, ",") > 0 Then
                .List = Split(xStr, ",")
            Else
                .ListFillRange = xStr
            End If
            .LinkedCell = Target.Address
        End With
        xCombox.Activate
        xCombox.DropDown
    End If
End Sub

Private Sub TempCombo_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    Select Case KeyCode
        Case 9
            Application.ActiveCell.Offset(0, 1).Activate
        Case 13
            Application.ActiveCell.Offset(1, 0).Activate
    End Select
End Sub

关键优化点说明 #

• 动态日期填充：根据选中月份自动计算并填充日期，无需手动维护日期序列
• 智能Fri列处理：先恢复所有历史清空的单元格为10，再定位当前月份的Fri列进行清空，确保月份切换时数据状态正确
• 兼容行增删：使用ws.Rows.Count动态获取最后一行，完美支持行的添加或删除操作
• 性能提升：关闭屏幕更新和事件触发，减少代码运行时的界面卡顿

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