Paste contents into cell that has color

Is there a way to paste/copy contents of a cell into the cell on that row with a background color?
Attachment 25126

I'm wanting which ever cell on the left is clicked/double clicked to populate the cell to the right that is in gray. Is this possible?

Here is what I have so far:

Code:

---

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, Range("C3:I" & Rows.Count)) Is Nothing Then Exit Sub
Range("K3").Value = Target.Offset(0, 0).Value
End Sub

---

I've gotten this to at least paste on the same row, but how do I make it paste into the column/cell with color?

Code:

---

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, Range("C3:I26,C30:I50")) Is Nothing Then Exit Sub
Range("K" & ActiveCell.Row).Value = Target.Offset(0, 0).Value
'color is 15
End Sub

---

I'm not sure if this is the best way, but I did figure something out for this:

Code:

---

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)   

If Intersect(Target, Range("C3:I26,C30:I50")) Is Nothing Then Exit Sub

Dim ws As Worksheet
Set ws = Sheets("Sheet1")

If ws.Range("K" & ActiveCell.Row).Interior.ColorIndex = 15 Then
    Range("K" & ActiveCell.Row).Value = Target.Offset(0, 0).Value
Else
If ws.Range("L" & ActiveCell.Row).Interior.ColorIndex = 15 Then
    Range("L" & ActiveCell.Row).Value = Target.Offset(0, 0).Value
Else
If ws.Range("M" & ActiveCell.Row).Interior.ColorIndex = 15 Then
    Range("M" & ActiveCell.Row).Value = Target.Offset(0, 0).Value
End If
End If
End If
'color is 15

End Sub

---

Hi, jwdesselle

I have modified your code like below.

Code:

---

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    If Intersect(Target, Range("C3:I26,C30:I50")) Is Nothing Then Exit Sub
   
    Dim Cell As Range
    Cancel = True
    For Each Cell In Range("K" & Target.Row).Resize(, 3)
        If Cell.Interior.ColorIndex = 15 Then
            Cell.Value = Target.Value
            Exit For
        End If
    Next Cell
End Sub

---

Or

Code:

---

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Dim i As Long
    If Intersect(Target, Range("C3:I26,C30:I50")) Is Nothing Then Exit Sub
    For i = 11 To 13
        If Cells(Target.Row, i).Interior.ColorIndex = 15 Then Cells(Target.Row, i) = Target
    Next
    Cancel = True
End Sub

---

Thanks yujin and paulked, both solutions you submitted worked perfectly. This is why I love computers, always more than one way to do what is needed.

Thanks again,
John

Quote:

---

This is why I love computers, always more than one way to do what is needed.

---

jwdesselle, I totally agree with you:yes Computers or programmings are really fun!