在现有工作表更改代码中添加第二个更改事件

问题:当用户在N2:N28列的某个单元格中输入日期时,Q列中的公式会自动运行

• 简化 Case 代码中的子句。
• 添加第二部分,在Q2:Q28上应用公式

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim DestWH As String
    Dim DWHRowNum As Long
    Dim toDay As String, nextDay As String
    DWHRowNum = 2
    toDay = Format(Date, "mm/dd/yyyy")
    nextDay = Format(Date + 1, "mm/dd/yyyy")
    Application.EnableEvents = False
    Do Until Cells(DWHRowNum, 2).Value = ""
        Select Case Cells(DWHRowNum, 6).Value
        Case "ABQ1", "CLE2", "DEN3", "GEG1", "LIT1", "ORD5", "ORF3", "PAE2", "PCW1", "SLC1"
            Cells(DWHRowNum, 7).Value = toDay
            Cells(DWHRowNum, 8).Value = "17:00"
        Case "BFI4", "DEN4", "PDX9", "SMF1"
            Cells(DWHRowNum, 7).Value = nextDay
            Cells(DWHRowNum, 8).Value = "04:30"
        End Select
        DWHRowNum = DWHRowNum + 1
    Loop
    ' ** Update
    With Target
        If .CountLarge = 1 Then
            If Not Application.Intersect(Target, Me.Range("N2:N28")) Is Nothing Then
                If Len(.Value) > 0 And IsDate(.Value) Then
                    If Not Me.Range("Q2").HasFormula Then
                        Me.Range("Q2:Q28").Formula = "=IF(G2="""","""",IF(AND(M2="""",N2>G2),""Future"",""Current""))"
                    End If
                End If
            End If
        End If
    End With
    Application.EnableEvents = True
End Sub

试试这个:

Private Sub Worksheet_Change(ByVal Target As Range)
    
    Dim rw As Range, dt, tm, vn, vm, vg
    
    On Error GoTo haveError 'so not to leave events turned off...
    Application.EnableEvents = False
    
    Set rw = Me.Rows(2) 'start with row2
    Do While Len(rw.Columns("B").Value) > 0
        Debug.Print rw.Row
        Select Case rw.Columns("F").Value
            'you can list multiple values in the same `Case`
            Case "ABQ1", "CLE2", "DEN3", "GEG1", "LIT1", _
                         "ORF3", "PAE2", "PCW1", "SLC1"
                dt = Date
                tm = "17:00"
            Case "BFI4", "DEN4", "PDX9", "SMF1"
                dt = dt + 1
                tm = "04:30"
            Case Else
                dt = Empty 'no match: clear variables
                tm = Empty
        End Select
        
        'now figure out what to do with Cols G, H and Q
        If Len(tm) > 0 Then 'any match above?
            rw.Columns("G").NumberFormat = "mm/dd/yyyy"
            rw.Columns("G").Value = dt
            rw.Columns("H").Value = tm
            
            vm = rw.Columns("M").Value
            vn = rw.Columns("N").Value
            vg = rw.Columns("G").Value
            rw.Columns("Q").Value = IIf(Len(vm) = 0 And vn > vg, "Future", "Current")
        Else
            'clear G, H and Q
            'note range is *relative* to `rw`
            rw.Range("G1,H1,Q1").ClearContents
        End If
        
        Set rw = rw.Offset(1) 'next row down
    Loop
haveError:
    If Err.Number > 0 Then Debug.Print Err.Description
    Application.EnableEvents = True
    
End Sub