Color background detection in a cell

[Hippo8]

Hi everyone, i'm facing some problems and i would like to ask for your help.

I have two columns with dates, where some of the dates are different.
Ex:

26-06-2009 16,07 26-06-2009
29-06-2009 16,22 29-06-2009
30-06-2009 16,09 30-06-2009
01-07-2009 16,24 01-07-2009
02-07-2009 16,04 02-07-2009
03-07-2009 16,03 06-07-2009
06-07-2009 16,04 07-07-2009
07-07-2009 16,01 08-07-2009
08-07-2009 15,92 09-07-2009

I need to search in all the file, for this situation an then copy the date in the left column to paste it in the right column. To stay like this:

26-06-2009 16,07 26-06-2009
29-06-2009 16,22 29-06-2009
30-06-2009 16,09 30-06-2009
01-07-2009 16,24 01-07-2009
02-07-2009 16,04 02-07-2009
03-07-2009 16,03 03-07-2009
06-07-2009 16,04 06-07-2009
07-07-2009 16,01 07-07-2009
08-07-2009 15,92 08-07-2009

With the conditional formatting i made all the different dates appear in red, which make the task more easy.

I'm now trying to automate the process with some vba. I'm trying to run the column A searching for a red background and then copy the date and insert as a new line in the other column.

Hope i express my self correctly.

If Range("A2:A1500").Interior.ColorIndex = -4142 Then

End If

I was trying some like this, there are a way so i know what the red background cell column and row are?

Then my objective is work with this recorded macro:

Range("C360:D360").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range("A360").Select
Selection.Copy
Range("C360").Select
ActiveSheet.Paste
Range("D359").Select
Application.CutCopyMode = False
Selection.Copy
Range("D360").Select
ActiveSheet.Paste

Adapting the column number automatically.

Thank You

[mod note: crossposted here.]

 

[John Davis]

Does this help?

Sub Hippo8()

Dim rcell As Range
Dim lr As Long

lr = Cells(Rows.Count, 1).End(xlUp).Row

For Each rcell In Range("A2:A" & lr)

    If rcell.Font.ColorIndex = 3 Then
    
        rcell.Offset(, 2).Value = rcell.Value
        
    End If
    
Next rcell

End Sub

 

[Hippo8]

Does this help?

Sub Hippo8()

Dim rcell As Range
Dim lr As Long

lr = Cells(Rows.Count, 1).End(xlUp).Row

For Each rcell In Range("A2:A" & lr)

    If rcell.Font.ColorIndex = 3 Then
    
        rcell.Offset(, 2).Value = rcell.Value
        
    End If
    
Next rcell

End Sub

Hi John,

Thank you very much for your help.

Sub Subst()
Dim rcell As Range
Dim lr As Long


lr = Cells(Rows.Count, 1).End(xlUp).Row
For Each rcell In Range("A2:A" & lr)
'MsgBox (rcell.Font.ColorIndex)
If rcell.Font.ColorIndex = 3 Then
rcell.Offset(, 4).Value = rcell.Value
'MsgBox (rcell)

Range(rcell.Offset(, 4)).Select
'Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
End If

Next rcell
End Sub

I'm having a problem making the selection. You know how can i select this 'cell':
rcell.Offset(, 4).Value = rcell.Value

I think that if i can select it, i'll then insert a new line and then make the rcell.

Thank You

 

[John Davis]

Maybe:

rcell.Offset(,4).Select

Not sure about what you are trying to achieve. Are you copying a value to an adjacent cell or inserting? Or do you want the formating copied to the adjacent cell (ie. Column C or is it Column D)

 

[MARK858]

Hippo8 I think you need to read the post made by Kenneth Hobs in your cross-post.

 

[Hippo8]

Maybe:

rcell.Offset(,4).Select

Not sure about what you are trying to achieve. Are you copying a value to an adjacent cell or inserting? Or do you want the formating copied to the adjacent cell (ie. Column C or is it Column D)

I'm copying a value from one cell to another, which your code really helped.

date	x	date	y
17	a	17	a
18	b	18	b
21	c	22	c
22	d	23	d

<tbody>
</tbody>

With this code:
Sub MINHA()
Dim rcell As Range
Dim lr As Long


lr = Cells(Rows.Count, 1).End(xlUp).Row
For Each rcell In Range("A2:A" & lr)
'MsgBox (rcell.Font.ColorIndex)
If rcell.Font.ColorIndex = 3 Then
rcell.Offset(, 2).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
rcell.Offset(, 3).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
rcell.Offset(, 2).Value = rcell.Value
End If

Next rcell
End Sub

I create a new row and insert the red date. Stay like that:

date	x	date	y
17	a	17	a
18	b	18	b
21	c	21
22	d	22	d

<tbody>
</tbody>

What i want to do now is insert the last value in the Y column. Ex:

date	x	date	y
17	a	17	a
18	b	18	b
21	c	21	b
22	d	22	d

<tbody>
</tbody>

Could you help me doing that?

Really appreciate.

Thank You

 

[MARK858]

Seeing as you are obviously not using conditional formatting...

rcell.Offset(, 3).Value = rcell.Offset(-1, 3).Value

 

[Hippo8]

Seeing as you are obviously not using conditional formatting...

rcell.Offset(, 3).Value = rcell.Offset(-1, 3).Value

I think thats working. Will run some more tests.

Thank you very much.

 

[John Davis]

Looks like Mark beat me to it. That should solve your problem.