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

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