VBA代码优化需求：遍历全部冲突对象检测日期范围冲突

问题描述 #

需要实现：当目标单元格不在指定日期范围内时，继续查找列中的下一个相同单元格进行检查。

场景示例1：项目冲突检查 #

现有项目列表，不同项目（如STACK、OVERFLOW）不能存在日期范围重叠。当前代码仅检查首个冲突项目，若日期无冲突则直接标记“OK”，未遍历所有同类型项目。

PROJECT           Start Date  End Date    Conflict?
 1. STACK            1/3/2020    1/20/2020
 2. OVERFLOW         5/6/2020    6/1/2020
 3. STACK            2/18/2020   3/4/2020
 4. STACK            3/9/2020    3/11/2020
 5. OVERFLOW         1/5/2020    1/15/2020

期望代码遍历整列，找到任意日期重叠则标记“CONFLICT”，全部无冲突才标记“OK”。

场景示例2：科目冲突检查 #

通过Key表定义科目冲突关系（如Library与PE冲突），当前代码仅检查首个匹配的冲突科目，未遍历所有同科目项。

Key表示例：

Subject   Conflict1       Conflict2       Conflict3
Library     PE      
PE         SocialS      
SocialS    Science          Library         Reading
Science     Math            Reading 
Math        PE      
Reading     Library          SocialS    

Master表示例（部分）：

A             B          C            D           E           F
1    Subject       Start      End       Conflict1   Conflict2   Conflict3
2    Library       1/13/20   1/13/20                
...

以A2的Library为例，代码仅检查A5的PE，未继续检查后续的PE项（如A26、A27），需修改实现遍历所有冲突科目。

当前代码 #

代码1：TEST Sub #

Option Explicit

Sub TEST()

    Dim FoundCell As Range

    Dim FoundCell1 As Range
    Dim FoundCell2 As Range

    Dim Subst As String
    Dim StartD As Date
    Dim EndD As Date
    Dim i As Integer
    Dim k As Long

    Dim Conflict1 As String
    Dim Conflict2 As String

    Dim StartRef1 As Date
    Dim EndRef1 As Date

    'set a counter for k - which is looping through each column
    Dim LastRow  As Long

    LastRow = Range("E" & Rows.Count).End(xlUp).Row

    For k = 8 To LastRow

        Subst = Sheets("Master").Range("E" & k).Value
    
        Set FoundCell = Sheets("Sub_Ref_Matrix").Range("B:B").Find(What:=Subst)
        i = FoundCell.Row
        
        'Retrieve both start and stop dates of substation
        StartD = Sheets("Master").Range("K" & k).Value
        EndD = Sheets("Master").Range("M" & k).Value

        'Get the conflict value (in this case would be "STACK" or "OVERFLOW")
        Conflict1 = Sheets("Sub_Ref_Matrix").Range("G" & i).Value
        Conflict2 = Sheets("Sub_Ref_Matrix").Range("H" & i).Value
  
        'If the Conflict1 is not blank
        If Conflict1 <> "" Then
            
            'Find the Conflict1 in the Master Sheet
            Set FoundCell1 = Sheets("Master").Range("E8:E" & LastRow).Find(What:=Conflict1)
                
            'If not blank then
            If Not FoundCell1 Is Nothing Then
                
                'Get Start and End dates of Conflict1
                StartRef1 = Sheets("Master").Range("K" & FoundCell1.Row).Value
                EndRef1 = Sheets("Master").Range("M" & FoundCell1.Row).Value
                
                'If the Start and Stop Conflict dates match with the Substation dates, then CONFLICT
                If (StartD >= StartRef1 And StartD <= EndRef1) And (EndD >= StartRef1 And EndD <= EndRef1) Then
                    Sheets("Master").Range("AS" & k).Value = "CONFLICT " & Conflict1 & " at E" & FoundCell1.Row
                Else
                    Sheets("Master").Range("AS" & k).Value = "OK"
                    If Sheets("Master").Range("AS" & k).Value = "OK" Then
                        Set FoundCell1 = Sheets("Master").Range("E:E").FindNext(FoundCell1)
                    End If
                End If
                       
            End If
        End If
                            
                            
        If Conflict2 <> "" Then
            Set FoundCell2 = Sheets("Master").Range("E8:E" & LastRow).Find(What:=Conflict2)
            
            If Not FoundCell2 Is Nothing Then
                StartRef1 = Sheets("Master").Range("K" & FoundCell2.Row).Value
                EndRef1 = Sheets("Master").Range("M" & FoundCell2.Row).Value
                
                If (StartD >= StartRef1 And StartD <= EndRef1) And (EndD >= StartRef1 And EndD <= EndRef1) Then
                    Sheets("Master").Range("AT" & k).Value = "CONFLICT " & Conflict2 & " at E" & FoundCell2.Row
                Else
                    Sheets("Master").Range("AT" & k).Value = "OK"
                       
                End If
            End If
        End If
                    
  
        'increment k to go through the entire column
    Next k
      
                        
End Sub

代码2：Conflicts Sub #

Sub Conflicts()

Dim Trans As String

Dim Conflict1 As String
Dim Conflict2 As String
Dim Conflict3 As String

Dim FoundCell As Range
Dim FoundCell1 As Range
Dim FoundCell2 As Range
Dim FoundCell3 As Range

Dim k As Long
Dim i As Long
Dim LastRow As Long

Dim StartD As Date
Dim EndD As Date
Dim StartRef As Date
Dim EndRef As Date

LastRow = Range("AH" & Rows.Count).End(xlUp).Row

For k = 2 To LastRow

    Subj = Sheets("Master").Range("A" & k).Value
    
        Set FoundCell = Sheets("Key").Range("A:A").Find(What:=Subj)
        If Not FoundCell Is Nothing Then
        i = FoundCell.Row
        
        'Retrieve both start and stop dates of substation
        StartD = Sheets("Master").Range("B" & k).Value
        EndD = Sheets("Master").Range("C" & k).Value
        
        Conflict1 = Sheets("Key").Range("J" & i).Value
        Conflict2 = Sheets("Key").Range("K" & i).Value
        Conflict3 = Sheets("Key").Range("L" & i).Value
        
    
        If Conflict1 <> "" Then
            Set FoundCell1 = Sheets("Master").Range("A2:A" & LastRow).Find(What:=Conflict1)
            If Not FoundCell1 Is Nothing Then
                StartRef = Sheets("Master").Range("B" & FoundCell1.Row).Value
                EndRef = Sheets("Master").Range("C" & FoundCell1.Row).Value
                 If (StartD >= StartRef And StartD <= EndRef) And (EndD >= StartRef And EndD <= EndRef) Then
                    Sheets("Master").Range("D" & k).Value = "CONFLICT " & Conflict1 & " at D" & FoundCell1.Row
                     Else
                       Sheets("Master").Range("D" & k).Value = "OK"
                       
                       End If
                        End If
                        End If
                        
                        
        If Conflict2 <> "" Then
            Set FoundCell2 = Sheets("Master").Range("A2:A" & LastRow).Find(What:=Conflict2)
            If Not FoundCell2 Is Nothing Then
                StartRef = Sheets("Master").Range("B" & FoundCell2.Row).Value
                EndRef = Sheets("Master").Range("C" & FoundCell2.Row).Value
                
                 If (StartD >= StartRef And StartD <= EndRef) And (EndD >= StartRef And EndD <= EndRef) Then
                    Sheets("Master").Range("E" & k).Value = "CONFLICT " & Conflict2 & " at D" & FoundCell2.Row
                     Else
                       Sheets("Master").Range("E" & k).Value = "OK"
                       
                       End If
                        End If
                        End If
                        
                        
        If Conflict3 <> "" Then
            Set FoundCell3 = Sheets("Master").Range("A2:A" & LastRow).Find(What:=Conflict3)
            If Not FoundCell3 Is Nothing Then
                StartRef = Sheets("Master").Range("B" & FoundCell3.Row).Value
                EndRef = Sheets("Master").Range("C" & FoundCell3.Row).Value
                
                 If (StartD >= StartRef And StartD <= EndRef) And (EndD >= StartRef And EndD <= EndRef) Then
                    Sheets("Master").Range("F" & k).Value = "CONFLICT " & Conflict3 & " at D" & FoundCell3.Row
                     Else
                       Sheets("Master").Range("F" & k).Value = "OK"
                       
                       End If
                        End If
                        End If
                        
  
                                                 
            End If
Next k


End Sub

修改后的代码 #

代码1：TEST Sub（修改版） #

Option Explicit

Sub TEST()
    Dim FoundCell As Range
    Dim FoundCell1 As Range
    Dim FoundCell2 As Range
    Dim Subst As String
    Dim StartD As Date
    Dim EndD As Date
    Dim i As Integer
    Dim k As Long
    Dim Conflict1 As String
    Dim Conflict2 As String
    Dim StartRef1 As Date
    Dim EndRef1 As Date
    Dim LastRow As Long
    Dim firstAddress As String
    
    LastRow = Sheets("Master").Range("E" & Rows.Count).End(xlUp).Row

    For k = 8 To LastRow
        Subst = Sheets("Master").Range("E" & k).Value
        
        Set FoundCell = Sheets("Sub_Ref_Matrix").Range("B:B").Find(What:=Subst)
        If FoundCell Is Nothing Then GoTo NextK ' 未找到对应项目，跳过
        i = FoundCell.Row
        
        StartD = Sheets("Master").Range("K" & k).Value
        EndD = Sheets("Master").Range("M" & k).Value

        Conflict1 = Sheets("Sub_Ref_Matrix").Range("G" & i).Value
        Conflict2 = Sheets("Sub_Ref_Matrix").Range("H" & i).Value
  
        ' 处理Conflict1
        If Conflict1 <> "" Then
            Sheets("Master").Range("AS" & k).Value = "OK" ' 默认标记OK，找到冲突再修改
            Set FoundCell1 = Sheets("Master").Range("E8:E" & LastRow).Find(What:=Conflict1, LookIn:=xlValues, LookAt:=xlWhole)
            If Not FoundCell1 Is Nothing Then
                firstAddress = FoundCell1.Address ' 记录首个匹配地址，避免死循环
                Do
                    StartRef1 = Sheets("Master").Range("K" & FoundCell1.Row).Value
                    EndRef1 = Sheets("Master").Range("M" & FoundCell1.Row).Value
                    
                    ' 检查日期范围是否重叠（覆盖所有重叠场景）
                    If Not (EndD < StartRef1 Or StartD > EndRef1) Then
                        Sheets("Master").Range("AS" & k).Value = "CONFLICT " & Conflict1 & " at E" & FoundCell1.Row
                        Exit Do ' 找到一个冲突即可停止遍历
                    End If
                    
                    Set FoundCell1 = Sheets("Master").Range("E8:E" & LastRow).FindNext(FoundCell1)
                Loop While Not FoundCell1 Is Nothing And FoundCell1.Address <> firstAddress
            End If
        End If
                            
        ' 处理Conflict2
        If Conflict2 <> "" Then
            Sheets("Master").Range("AT" & k).Value = "OK" ' 默认标记OK
            Set FoundCell2 = Sheets("Master").Range("E8:E" & LastRow).Find(What:=Conflict2, LookIn:=xlValues, LookAt:=xlWhole)
            If Not FoundCell2 Is Nothing Then
                firstAddress = FoundCell2.Address
                Do
                    StartRef1 = Sheets("Master").Range("K" & FoundCell2.Row).Value
                    EndRef1 = Sheets("Master").Range("M" & FoundCell2.Row).Value
                    
                    If Not (EndD < StartRef1 Or StartD > EndRef1) Then
                        Sheets("Master").Range("AT" & k).Value = "CONFLICT " & Conflict2 & " at E" & FoundCell2.Row
                        Exit Do
                    End If
                    
                    Set FoundCell2 = Sheets("Master").Range("E8:E" & LastRow).FindNext(FoundCell2)
                Loop While Not FoundCell2 Is Nothing And FoundCell2.Address <> firstAddress
            End If
        End If
NextK:
    Next k
End Sub

代码2：Conflicts Sub（修改版） #

Sub Conflicts()
    Dim Subj As String
    Dim Conflict1 As String
    Dim Conflict2 As String
    Dim Conflict3 As String
    Dim FoundCell As Range
    Dim FoundCell1 As Range
    Dim FoundCell2 As Range
    Dim FoundCell3 As Range
    Dim k As Long
    Dim i As Long
    Dim LastRow As Long
    Dim StartD As Date
    Dim EndD As Date
    Dim StartRef As Date
    Dim EndRef As Date
    Dim firstAddress As String
    
    LastRow = Sheets("Master").Range("AH" & Rows.Count).End(xlUp).Row

    For k = 2 To LastRow
        Subj = Sheets("Master").Range("A" & k).Value
        
        Set FoundCell = Sheets("Key").Range("A:A").Find(What:=Subj, LookIn:=xlValues, LookAt:=xlWhole)
        If FoundCell Is Nothing Then GoTo NextK
        i = FoundCell.Row
        
        StartD = Sheets("Master").Range("B" & k).Value
        EndD = Sheets("Master").Range("C" & k).Value
        
        Conflict1 = Sheets("Key").Range("J" & i).Value
        Conflict2 = Sheets("Key").Range("K" & i).Value
        Conflict3 = Sheets("Key").Range("L" & i).Value
        
        ' 处理Conflict1
        If Conflict1 <> "" Then
            Sheets("Master").Range("D" & k).Value = "OK"
            Set FoundCell1 = Sheets("Master").Range("A2:A" & LastRow).Find(What:=Conflict1, LookIn:=xlValues, LookAt:=xlWhole)
            If Not FoundCell1 Is Nothing Then
                firstAddress = FoundCell1.Address
                Do
                    StartRef = Sheets("Master").Range("B" & FoundCell1.Row).Value
                    EndRef = Sheets("Master").Range("C" & FoundCell1.Row).Value
                    
                    If Not (EndD < StartRef Or StartD > EndRef) Then
                        Sheets("Master").Range("D" & k).Value = "CONFLICT " & Conflict1 & " at A" & FoundCell1.Row
                        Exit Do
                    End If
                    
                    Set FoundCell1 = Sheets("Master").Range("A2:A" & LastRow).FindNext(FoundCell1)
                Loop While Not FoundCell1 Is Nothing And FoundCell1.Address <> firstAddress
            End If
        End If
                        
        ' 处理Conflict2
        If Conflict2 <> "" Then
            Sheets("Master").Range("E" & k).Value = "OK"
            Set FoundCell2 = Sheets("Master").Range("A2:A" & LastRow).Find(What:=Conflict2, LookIn:=xlValues, LookAt:=xlWhole)
            If Not FoundCell2 Is Nothing Then
                firstAddress = FoundCell2.Address
                Do
                    StartRef = Sheets("Master").Range("B" & FoundCell2.Row).Value
                    EndRef = Sheets("Master").Range("C" & FoundCell2.Row).Value
                    
                    If Not (EndD < StartRef Or StartD > EndRef) Then
                        Sheets("Master").Range("E" & k).Value = "CONFLICT " & Conflict2 & " at A" & FoundCell2.Row
                        Exit Do
                    End If
                    
                    Set FoundCell2 = Sheets("Master").Range("A2:A" & LastRow).FindNext(FoundCell2)
                Loop While Not FoundCell2 Is Nothing And FoundCell2.Address <> firstAddress
            End If
        End If
                        
        ' 处理Conflict3
        If Conflict3 <> "" Then
            Sheets("Master").Range("F" & k).Value = "OK"
            Set FoundCell3 = Sheets("Master").Range("A2:A" & LastRow).Find(What:=Conflict3, LookIn:=xlValues, LookAt:=xlWhole)
            If Not FoundCell3 Is Nothing Then
                firstAddress = FoundCell3.Address
                Do
                    StartRef = Sheets("Master").Range("B" & FoundCell3.Row).Value
                    EndRef = Sheets("Master").Range("C" & FoundCell3.Row).Value
                    
                    If Not (EndD < StartRef Or StartD > EndRef) Then
                        Sheets("Master").Range("F" & k).Value = "CONFLICT " & Conflict3 & " at A" & FoundCell3.Row
                        Exit Do
                    End If