Fill up color on duplicate date\time in another column cell

[IKHAN]

Searching for VBA script to do following :

1. If color filled up in Column E cell , Search and match date\time in column D and fillup with same color.

excel version 2010

Note: Have other macros running on same spreadsheet for other activities

 

[YasserKhalil]

May be

Sub Test()
    Dim cell As Range, rg As Range
    For Each cell In Range("E4:E19")
        If cell.Interior.ColorIndex <> 2 Then
            For Each rg In Range("D4:D19")
                If cell.Value = rg.Value Then rg.Interior.ColorIndex = cell.Interior.ColorIndex
            Next rg
        End If
    Next cell
End Sub

 

[YasserKhalil]

Or the following
(the same but using Color not ColorIndex .. more accurate)

Sub TestB()
    Dim cell As Range, rg As Range
    For Each cell In Range("E4:E19")
        If cell.Interior.Color <> 16777215 Then
            For Each rg In Range("D4:D19")
                If cell.Value = rg.Value Then rg.Interior.Color = cell.Interior.Color
            Next rg
        End If
    Next cell
End Sub

 

[IKHAN]

Thanks for the macro , It makes life much easier , have around 1000 lines of data with dates\times

Need minor fixes

1.After running macro and if fillup color is cleared (No fill) and macro executed again,Macro doesn't clear the filled up color in matched cell columns.

2.Forgot to add this in my initial question - If Filled up any color in column D should find any matched date time in column D and fill up with same color.

3. As mentioned earlier,have around 1000 lines of data and if color has already been chosen in the list,it should choose a different fill up color.

 

[IKHAN]

uploaded test file with request

 

[jindon]

Try

Sub test()
    Dim r As Range, c As Range, ff As String
    Columns("e").Interior.ColorIndex = xlNone
    For Each r In Range("d4", Range("d" & Rows.Count).End(xlUp))
        If (r.Value <> "") * (r.Interior.ColorIndex <> xlNone) Then
            Set c = Columns("e").Find(r.Text, , -4163, 1)
            If Not c Is Nothing Then
                ff = c.Address
                Do
                    c.Interior.Color = r.Interior.Color
                    Set c = Columns("e").FindNext(c)
                Loop Until ff = c.Address
            End If
        End If
    Next
End Sub