View Full Version : [SOLVED:] VBA Loop through column, copy specific cells, and stop when i meets a red cell? HELP
JulieD
02-07-2022, 12:39 AM
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
02-07-2022, 01:01 AM
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
02-07-2022, 07:24 AM
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
02-07-2022, 07:43 AM
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
02-07-2022, 08:37 AM
Hmmm. it comes back with a 424 error in If .Interior.Color.Index = 6 Then :think:
georgiboy
02-07-2022, 08:54 AM
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
02-07-2022, 09:04 AM
29391
It's regarding to the C column in "kalkulation!"
And then it must paste it to "tilbud!" A54
georgiboy
02-07-2022, 09:16 AM
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
02-07-2022, 09:43 AM
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
02-07-2022, 10:51 AM
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
02-07-2022, 11:18 AM
Aaaaaahhhh it works!!! Thank you so much!!!!
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
02-08-2022, 04:00 AM
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
02-08-2022, 04:03 AM
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
02-08-2022, 04:39 AM
It works perfectly! You are a lifesaver! :D
Powered by vBulletin® Version 4.2.5 Copyright © 2024 vBulletin Solutions Inc. All rights reserved.