突出显示符合条件的单元格

Question

我刚开始使用 VBA，需要一些指导。 目标：在这 4 个条件下突出显示单元格。必须满足所有条件

1. 同一天
2. 同名
3. 差异地址

4. 重叠时间

   示例：

   data 1> start time: 09:00 end time: 09:35

   data 2> start time: 09:20 end time: 10:00

   `当第二个数据的开始时间与第二个数据的结束时间重叠时 第一个数据，应该突出显示

样本数据：

样本输出：

我已经做了什么：

 Sub HighlightCells()
    Dim cel As Variant
    Dim rng As Range
    Dim clr As Long

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Set rng = Range("A1:A" & Range("A1048576").End(xlUp).Row)
    rng.Interior.ColorIndex = xlNone
    clr = 3

    For Each cel In rng
       If Application.WorksheetFunction.CountIf(rng, cel) > 1 Then
         If WorksheetFunction.CountIf(Range("A1:A" & cel.Row), cel) = 1 Then
           cel.Interior.ColorIndex = clr
           clr = clr + 1
         Else
           cel.Interior.ColorIndex = rng.Cells(WorksheetFunction.Match(cel.Value, rng, False), 1).Interior.ColorIndex
         End If
       End If
    Next

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
 End Sub

它只突出显示第一列中的重复项

Answer 1

如果您只需要包含所有 5 列，那么这应该可以工作...

 Sub HighlightCells()
    Dim cel As Range 'I think you want range for better functionality.
    Dim rng As Range
    Dim clr As Long
    Dim AdditionalColumnsToHighlight As Integer

    AdditionalColumnsToHighlight = 4 ' means 5 columns total

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Set rng = Range("A1:A" & Range("A1048576").End(xlUp).Row)
    rng.Interior.ColorIndex = xlNone
    clr = 3

    For Each cel In rng
       If Application.WorksheetFunction.CountIf(rng, cel) > 1 Then
         If WorksheetFunction.CountIf(Range("A1:A" & cel.Row), cel) = 1 Then
           Range(cel, cel.Offset(0, AdditionalColumnsToHighlight)).Interior.ColorIndex = clr 'this allows you to make the range as many columns over as specified above.
           clr = clr + 1
         Else
           Range(cel, cel.Offset(0, AdditionalColumnsToHighlight)).Interior.ColorIndex = rng.Cells(WorksheetFunction.Match(cel.Value, rng, False), 1).Interior.ColorIndex
         End If
       End If
    Next

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
 End Sub