VBA- Highlight cells that meet criteria

I just started using VBA and need some guidance.
Aim: Highlight cells upon this 4 conditions. All conditions have to be applied

1.Same Date
2.Same Name
3.Diff Address
4.Overlapping timing
    example:
   data 1> start time: 09:00 end time: 09:35
   data 2> start time: 09:20 end time: 10:00
   When the start time of the second data overlaps with the end time of the first data, it should be highlighted

Sample data:

sample data
Sample Output:

Sample output
What I have done:

Sub DupEntry()
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
excel vba excel-vba

Open in new window


It only highlights the duplicate in the first column

Any help would be appreciated. Thank you!
samsun razviyahAsked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Ryan ChongCommented:
to make adjustment for your criterion of:
1.Same Date
2.Same Name
3.Diff Address

you can customize:

Sub DupEntry()
    Dim rng As Range, cel As Range
    Dim lastRow As Integer
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    lastRow = Cells(Rows.Count, "A").End(xlUp).Row
    Set rng = Range("A1:A" & lastRow)
    Range("A1:E" & lastRow).Cells.Interior.ColorIndex = xlNone
    
    For Each cel In rng
        If Application.WorksheetFunction.CountIf(rng, cel) > 1 Then
            If WorksheetFunction.CountIfs(Range("A1:A" & lastRow), cel, Range("D1:D" & lastRow), cel.Offset(0, 3), Range("E1:E" & lastRow), "<>" & cel.Offset(0, 4)) >= 1 Then 'COUNTIFS(A:A,A2,D:D,D2,E:E,"<>"&E2)
                Range("A" & cel.Row & ":E" & cel.Row).Cells.Interior.ColorIndex = 6
                clr = clr + 1
            Else
                Range("A" & cel.Row & ":E" & cel.Row).Cells.Interior.ColorIndex = xlNone
            End If
        End If
    Next
    
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

Open in new window


to include the condition #4, we need to know more from you:
is that true the "repeated" (second) row is always just after the first row?
is that possible to have more than 1 repeated row?
if they are not overlapped, do you still want to highlight it? (i believe the answer is No?)
1
samsun razviyahAuthor Commented:
Yes, there is possibilities to have more than 1 repeated row. No it does not appear just after the first row. Do not highlight if it does not overlap. Thank u so much!
0
Neil FlemingConsultant and developerCommented:
I think the main issue with your code is that it will only find the first duplicate.

I would suggest something like the following code, also included in the attached file.

This loops through each row in the table and compares it with all other rows that follow it. No use of "countif" etc, simply applies comparative conditions to each row

Sub FindDuplicates()
Dim rRow As Range, rCompare As Range
Dim iClr As Long

'set rRow to all cells (assumes no blank rows in your data.. otherwise use your end.xlup formulation)
Set rRow = ActiveSheet.Cells(1, 1).CurrentRegion
'clear colors
rRow.Interior.ColorIndex = xlNone

'resize rRow to a single row, the first one:
Set rRow = rRow.Resize(1, rRow.Columns.Count)
'set initial color index
iClr = 2
'loop through all rows
Do
    'start by comparing next row:
    Set rCompare = rRow.Offset(1, 0)
    'loop all rows for comparison, stop if first cell in comparison row is blank
    Do While rCompare(1) <> ""
        'check for same date, same name, different address:
        If ((rCompare(1) = rRow(1)) And (rCompare(4) = rRow(4))) And (rCompare(5) <> rRow(5)) Then
            'if start time of comparison row is greater or equal to start time
            'of row being checked, and comparison start time is less than end time
            'of row being checked, apply color:
            If (rCompare(2) >= rRow(2)) And (rCompare(2) <= rRow(3)) Then
                'if no color applied yet: increment color index and apply it
                If rRow.Interior.ColorIndex = xlNone Then
                iClr = iClr + 1
                rRow.Interior.ColorIndex = iClr
                rCompare.Interior.ColorIndex = iClr
                Else
                'already a color applied, so use this pre-existing color:
                rCompare.Interior.ColorIndex = rRow.Interior.ColorIndex
                End If
            End If
        End If
    Set rCompare = rCompare.Offset(1, 0)
    Loop
'move to next row and repeat:
Set rRow = rRow.Offset(1, 0)
Loop Until rRow(1) = ""

End Sub

Open in new window


Hope this helps. I've attached the code to a button in the file attached.
duplicates.xlsm
1

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
samsun razviyahAuthor Commented:
Thank u sooo much! The code works:)
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Office

From novice to tech pro — start learning today.

Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.