如何修改Excel VBA代码将选中课程按时间同步至Calendar工作表？

用户参与学校Workshop时，同一时段有多门课程可选。现有VBA代码可实现选中某门课程为"Yes"时，自动将同时段其他课程设为"No"并添加删除线；现需改造代码，新增将选中课程按时间信息同步至名为"calendar"的工作表的功能。

原代码如下：

Private Sub Worksheet_Change(ByVal Target As Range)

Dim c As Range

Endrow = Range("A" & Rows.Count).End(xlUp).Row

For Each c In Range("A1:A" & Endrow)
  If c.Value = "No" Then
     c.EntireRow.Font.strikethrough = True
  Else
     c.EntireRow.Interior.ColorIndex = xlColorIndexNone
     c.EntireRow.Font.strikethrough = False
  End If
Next
   
End Sub

改造后的VBA代码 #

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim c As Range
    Dim endRow As Long
    Dim timeCol As Integer ' 存储时间信息的列号，可自行调整
    Dim courseCol As Integer ' 存储课程名称的列号，可自行调整
    Dim calSheet As Worksheet
    Dim calLastRow As Long
    Dim isDuplicate As Boolean
    Dim i As Long
    Dim currentTime As Variant
    
    ' 根据你的实际表格结构修改列号
    timeCol = 2 ' 示例：时间信息在B列
    courseCol = 3 ' 示例：课程名称在C列
    Set calSheet = ThisWorkbook.Worksheets("calendar")
    
    ' 仅当修改的是"Yes/No"列（示例为A列）时执行逻辑
    If Target.Column <> 1 Then Exit Sub
    
    Application.EnableEvents = False ' 防止触发循环事件
    
    endRow = Range("A" & Rows.Count).End(xlUp).Row
    
    ' 保留原功能：同一时段课程排他处理
    For Each c In Range("A1:A" & endRow)
        currentTime = c.Offset(0, timeCol - 1).Value
        ' 同时间段内，仅选中的课程保留"Yes"，其余设为"No"并添加删除线
        If c.Address <> Target.Address And currentTime = Target.Offset(0, timeCol - 1).Value Then
            c.Value = "No"
            c.EntireRow.Font.Strikethrough = True
        ElseIf c.Value = "Yes" Then
            c.EntireRow.Interior.ColorIndex = xlColorIndexNone
            c.EntireRow.Font.Strikethrough = False
        ElseIf c.Value = "No" Then
            c.EntireRow.Font.Strikethrough = True
        End If
    Next c
    
    ' 新增功能：同步选中课程至calendar表
    If Target.Value = "Yes" Then
        ' 检查日历表中是否已存在该时段课程
        isDuplicate = False
        calLastRow = calSheet.Range("A" & Rows.Count).End(xlUp).Row
        For i = 1 To calLastRow
            If calSheet.Cells(i, 1).Value = Target.Offset(0, timeCol - 1).Value Then
                isDuplicate = True
                calSheet.Cells(i, 2).Value = Target.Offset(0, courseCol - 1).Value ' 更新课程名称
                Exit For
            End If
        Next i
        
        ' 无重复则新增行
        If Not isDuplicate Then
            calLastRow = calLastRow + 1
            calSheet.Cells(calLastRow, 1).Value = Target.Offset(0, timeCol - 1).Value
            calSheet.Cells(calLastRow, 2).Value = Target.Offset(0, courseCol - 1).Value
        End If
    ElseIf Target.Value = "No" Then
        ' 取消选择时，从日历表删除对应课程
        calLastRow = calSheet.Range("A" & Rows.Count).End(xlUp).Row
        For i = calLastRow To 1 Step -1
            If calSheet.Cells(i, 1).Value = Target.Offset(0, timeCol - 1).Value And _
               calSheet.Cells(i, 2).Value = Target.Offset(0, courseCol - 1).Value Then
                calSheet.Rows(i).Delete
                Exit For
            End If
        Next i
    End If
    
    Application.EnableEvents = True
End Sub

关键说明 #

• 列号配置：代码中timeCol和courseCol需根据你的实际表格结构修改（比如时间在D列则设为4，课程名在E列则设为5）。
• 排他逻辑优化：新增时间段匹配判断，确保仅同时段课程会被设为"No"，不同时段课程不受影响。
• Calendar同步规则：
  • 选中"Yes"时，自动检查日历表，已有同时段课程则更新名称，无则新增行。
  • 改为"No"时，自动从日历表删除对应课程条目。
• 事件防护：通过Application.EnableEvents = False避免代码执行时触发多次Worksheet_Change事件，防止逻辑混乱。

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