match color column

[Urraco]

Hi,
a little problem...
columns A:D are filled with dates starting with 1992-01-01...
column E is filled with the same dates but distributed over one column
some data on column E is font colored in red
I want to add a "<" symbol to the dates in A:D that corresponds to the red color data in column E
i.e. if 1992-01-05 in column E is in red, then 1992-01-05 in columns A:D will become 1992-01-05<
how can this be done?
thanks

Book1.xlsx
	A	B	C	D	E
1	1992-01-01	1992-01-02	1992-01-03	1992-01-04	1992-01-01
2	1992-01-05	1992-01-06	1992-01-07	1992-01-08	1992-01-02
3	1992-01-09	1992-01-10	1992-01-11	1992-01-12	1992-01-03
4	1992-01-13	1992-01-14	1992-01-15	1992-01-16	1992-01-04
5	1992-01-17	1992-01-18	1992-01-19	1992-01-20	1992-01-05
6	1992-01-21	1992-01-22	1992-01-23	1992-01-24	1992-01-06
7	1992-01-25	1992-01-26	1992-01-27	1992-01-28	1992-01-07
8	1992-01-29	1992-01-30	1992-01-31	1992-02-01	1992-01-08
9	1992-02-02	1992-02-03	1992-02-04	1992-02-05	1992-01-09
10	1992-02-06	1992-02-07	1992-02-08	1992-02-09	1992-01-10
11	1992-02-10	1992-02-11	1992-02-12	1992-02-13	1992-01-11
12	1992-02-14	1992-02-15	1992-02-16	1992-02-17	1992-01-12
13	1992-02-18	1992-02-19	1992-02-20	1992-02-21	1992-01-13
14	1992-02-22	1992-02-23	1992-02-24	1992-02-25	1992-01-14
15	1992-02-26	1992-02-27	1992-02-28	1992-02-29	1992-01-15
16	1992-03-01	1992-03-02	1992-03-03	1992-03-04	1992-01-16
17	1992-03-05	1992-03-06	1992-03-07	1992-03-08	1992-01-17
18	1992-03-09	1992-03-10	1992-03-11	1992-03-12	1992-01-18
19					1992-01-19
20					1992-01-20
21					1992-01-21
22					1992-01-22
23					1992-01-23
24					1992-01-24
25					1992-01-25
26					1992-01-26
27					1992-01-27
28					1992-01-28
29					1992-01-29
30					1992-01-30
31					1992-01-31
32					1992-02-01
Sheet4

 

[Legacy 143009]

Hi,

This will work for you:

Sub test()
  Dim columnE As Range, columnsAD As Variant, lRow As Long, i As Long, j As Long
  Dim redDates As Object
  Set redDates = CreateObject("Scripting.Dictionary")
  lRow = Cells(Rows.Count, "E").End(xlUp).Row
 
  Set columnE = Range("E1:E" & lRow)
  columnsAD = Range("A1:D" & lRow)
 
  For Each Rng In columnE
    If Not redDates.Exists(Rng.Value) And Rng.Font.Color = 255 Then
      redDates.Add Rng.Value, 1
    End If
  Next
 
  For i = 1 To UBound(columnsAD, 1)
    For j = 1 To UBound(columnsAD, 2)
      If redDates.Exists(columnsAD(i, j)) Then
        columnsAD(i, j) = Format(columnsAD(i, j), "yyyy-mm-dd") & "<"
      End If
    Next
  Next
  Range("A1").Resize(UBound(columnsAD, 1), UBound(columnsAD, 2)).Value = columnsAD
End Sub

 

[Georgiboy]

If you only have one instance of each date to change in columns A:D then the below find loop will work:

Sub test()
    Dim lkupRng As Range, MasterRng As Range, rCell As Range, fCell As Range
    
    Set lkupRng = Range("A1:D" & Range("A" & Rows.Count).End(xlUp).Row)
    Set MasterRng = Range("E1:E" & Range("E" & Rows.Count).End(xlUp).Row)
    
    For Each rCell In MasterRng
        If rCell.Font.Color = vbRed Then
            Set fCell = lkupRng.Find(rCell.Value, , , xlWhole)
            If Not fCell Is Nothing Then
                fCell = fCell & "<"
            End If
            Set fCell = Nothing
        End If
    Next rCell
End Sub

 

[Legacy 143009]

Hi @Georgiboy
If I were you I would avoid two issues:
1. Set lkupRng = Range("A1:D" & Range("A" & Rows.Count).End(xlUp).Row) Not all of the columns might be in the same length.
Column E would be the safest length since it includes all the values.
2. fCell = fCell & "<" this may reset the formatting to the default date format.

 

[Georgiboy]

Hi @Flashbond
If I were you I would make sure all of your variables are defined.
Rng has not been defined so the code returns an error if 'Opton Explicit' is used.

 

[Legacy 143009]

Hi @Flashbond
If I were you I would make sure all of your variables are defined.
Rng has not been defined so the code returns an error if 'Opton Explicit' is used.

I know, I know...

 

[Urraco]

very good code!
Thank you!

Hi,

This will work for you:

Sub test()
  Dim columnE As Range, columnsAD As Variant, lRow As Long, i As Long, j As Long
  Dim redDates As Object
  Set redDates = CreateObject("Scripting.Dictionary")
  lRow = Cells(Rows.Count, "E").End(xlUp).Row
 
  Set columnE = Range("E1:E" & lRow)
  columnsAD = Range("A1:D" & lRow)
 
  For Each Rng In columnE
    If Not redDates.Exists(Rng.Value) And Rng.Font.Color = 255 Then
      redDates.Add Rng.Value, 1
    End If
  Next
 
  For i = 1 To UBound(columnsAD, 1)
    For j = 1 To UBound(columnsAD, 2)
      If redDates.Exists(columnsAD(i, j)) Then
        columnsAD(i, j) = Format(columnsAD(i, j), "yyyy-mm-dd") & "<"
      End If
    Next
  Next
  Range("A1").Resize(UBound(columnsAD, 1), UBound(columnsAD, 2)).Value = columnsAD
End Sub

 

[Legacy 143009]

Glad it did work Thanks for the feedback