VBA Loop through column, copy specific cells, and stop when i meets a red cell? HELP

[JulieD]

Hi, i'm very new to VBA and hope some kind soul can help.
I need to make a code that runs through column C, and every time it meets a yellow cell it copys C, D and E and pastes it to another sheet. The loop has to stop when it meets a red cell. Kind regards

[georgiboy]

Hi Julie,

If you want to loop through and do it line by line then maybe the below:

Sub test()
Dim Rng As Range, rCell As Range, nr As Long

Set Rng = Sheet1.Range("C2:C" & Range("C" & Rows.Count).End(xlUp).Row)

For Each rCell In Rng.Cells
With rCell
If .Interior.Color = vbYellow Then
nr = Sheet2.Range("C" & Rows.Count).End(xlUp).Row + 1
.Resize(1, 3).Copy Sheet2.Range("C" & nr)
ElseIf .Interior.Color = vbRed Then
MsgBox "Complete@ " & rCell.Address
Exit Sub
End If
End With
Next rCell
End Sub

The other option may be to filter by colour but that would go past the red cell if there are more ellow cells after it.

Hope this helps

[JulieD]

Thanks for the answer. I couldn't seem to get it to work. I tried with different variation. Some not working and some almost working. The main problem seems, when its pasted it only paste the first yellow cell.

I tried:

(not working)

Sub dowhileloop()
For Each cell In Range("c10:c500")
Do While ActiveCell.Interior.ColorIndex <> 6

Set newrange = Range(ActiveCell, ActiveCell.Offset(0, 2))
If ActiveCell.Interior.ColorIndex <> 3 Then
Exit Do
End If
Loop

newrange.Copy
Sheets("tilbud").Select
Range("A54").Select
ActiveSheet.Paste

Next
End Sub


And

(Only paste first yellow line)

Sub SelectByColor_2()
Dim cell As Range, u As Boolean
For Each cell In Range("c10:c500")
If cell.Interior.ColorIndex = 6 Then
If u = False Then cell.Select: u = True
Set newrange = Range(ActiveCell, ActiveCell.Offset(0, 2))
newrange.Copy
Sheets("tilbud").Select
Range("A54").Select
ActiveSheet.Paste

End If
Next
End Sub


Once again thank you so much for your help :)

[georgiboy]

Try this - it has been changed to colour index:

Sub test()
Dim Rng As Range, rcell As Range, nr As Long

Set Rng = Sheet1.Range("C2:C" & Sheet1.Range("C" & Rows.Count).End(xlUp).Row)

For Each rcell In Rng.Cells
With rcell
If .Interior.Color.Index = 6 Then
nr = Sheet2.Range("C" & Rows.Count).End(xlUp).Row + 1
.Resize(1, 3).Copy Sheet2.Range("C" & nr)
ElseIf .Interior.Color.Index = 3 Then
MsgBox "Complete@ " & rcell.Address
Exit Sub
End If
End With
Next rcell
End Sub

[JulieD]

Hmmm. it comes back with a 424 error in If .Interior.Color.Index = 6 Then :think:

[georgiboy]

Are you able to upload a basic spreadsheet with the colours you are using and layout of the file. Strip anything sensitive out or just make a dummy file?

[JulieD]

29391

It's regarding to the C column in "kalkulation!"

And then it must paste it to "tilbud!" A54

[georgiboy]

Hmm it looks like a made an error with color.index = 6 that should have been ColorIndex = 6


Sub test()
Dim Rng As Range, rCell As Range, nr As Long
Sheets("Kalkulation").Activate
Set Rng = ActiveSheet.Range("C2:C" & Range("C" & Rows.Count).End(xlUp).Row)

For Each rCell In Rng.Cells
With rCell
Debug.Print .Address
If rCell.Interior.ColorIndex = 6 Then
nr = Sheet4.Range("C" & Rows.Count).End(xlUp).Row + 1
.Resize(1, 3).Copy Sheet4.Range("C" & nr)
ElseIf .Interior.ColorIndex = 3 Then
MsgBox "Complete@ " & rCell.Address
Exit Sub
End If
End With
Next rCell
End Sub

[JulieD]

It seems i still get the 424 error. I'm sorry to be of trouble. Im doing an obligatory class, and have only been at it for five days. And as I'm studying landscaping architecture, Excel is not my strongest side :whistle:

[Bob Phillips]

Try this


Sub test()
Dim Rng As Range, rcell As Range, nr As Long

Application.ScreenUpdating = False

With Worksheets("Kalkulation")

Set Rng = .Range("C2:C" & .Range("C" & .Rows.Count).End(xlUp).Row)
nr = 54

For Each rcell In Rng.Cells

With rcell

If .Interior.ColorIndex = 6 Then

Worksheets("Tilbud").Cells(nr, "A").Resize(1000, 3).ClearContents
.Resize(1, 3).Copy Worksheets("Tilbud").Cells(nr, "A")
nr = nr + 1
ElseIf .Interior.ColorIndex = 3 Then

MsgBox "Complete@ " & rcell.Address
Exit Sub
End If
End With
Next rcell
End With

Application.ScreenUpdating = True
End Sub

[JulieD]

Aaaaaahhhh it works!!! Thank you so much!!!!

[SamT]

Neither Excel nor VBA can recognise cells colored by Conditional Formatting. If using CF, you will need to parse the Rules and decide if any cell meets those rules.

[JulieD]

If i may be of a bit more trouble. How do i make it paste the cells as a value. The cells i have to copy are a formula, so when i paste it, the value doesn't translate. Once again thank you :)

[georgiboy]

This should do it:

Sub test()
Dim Rng As Range, rcell As Range, nr As Long

Application.ScreenUpdating = False
With Worksheets("Kalkulation")
Set Rng = .Range("C2:C" & .Range("C" & .Rows.Count).End(xlUp).Row)
nr = 54
For Each rcell In Rng.Cells
With rcell
If .Interior.ColorIndex = 6 Then
Worksheets("Tilbud").Cells(nr, "A").Resize(1000, 3).ClearContents
.Resize(1, 3).Copy
Worksheets("Tilbud").Cells(nr, "A").PasteSpecial xlValues
Application.CutCopyMode = False
nr = nr + 1
ElseIf .Interior.ColorIndex = 3 Then
MsgBox "Complete@ " & rcell.Address
Exit Sub
End If
End With
Next rcell
End With
Application.ScreenUpdating = True
End Sub

[JulieD]

It works perfectly! You are a lifesaver! :D