VBA Copy and Paste Based on Cell Color

pahickham

New Member
Joined
Jun 5, 2017
Messages
39
All,

I need help with this code. My goal's for it to copy and paste red cells from sheet1 to sheet2 and green cells to sheet3. The current issues I'm having are when the data is cleared from sheets2/3 the new information isn't posted begging at cell A2. Also the data is posted in a reverse order. For instance if cells A2 and A4 should be posted on Sheet2, it'll post A4 before A2. The current code I have was pieced together from similar examples online, as you can probably tell. I appreciate any help!

VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim lr As Long, lr2 As Long, r As Long
lr = Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
lr2 = Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Row
lr3 = Sheets("Sheet3").Cells(Rows.Count, "A").End(xlUp).Row

Sheet2.Range("A1").CurrentRegion.Offset(1).ClearContents
Sheet3.Range("A1").CurrentRegion.Offset(1).ClearContents

For r = lr To 2 Step -1
    If Range("A" & r).Interior.Color = RGB(255, 0, 0) Then
        Rows(r).Copy Destination:=Sheets("Sheet2").Range("A" & lr2 + 1)
        lr2 = Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Row
    End If
    If Range("A" & r).Interior.Color = RGB(0, 176, 80) Then
        Rows(r).Copy Destination:=Sheets("Sheet3").Range("A" & lr3 + 1)
        lr3 = Sheets("Sheet3").Cells(Rows.Count, "A").End(xlUp).Row
    End If
    Range("A1").Select
Next r
End Sub
 

Excel Facts

Excel Can Read to You
Customize Quick Access Toolbar. From All Commands, add Speak Cells or Speak Cells on Enter to QAT. Select cells. Press Speak Cells.
try this:
VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim lr As Long, lr2 As Long, r As Long
lr = Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
'lr2 = Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Row
lr2 = 2
'lr3 = Sheets("Sheet3").Cells(Rows.Count, "A").End(xlUp).Row
lr3 = 2
Sheet2.Range("A1").CurrentRegion.Offset(1).ClearContents
Sheet3.Range("A1").CurrentRegion.Offset(1).ClearContents

For r = 2 To lr
    If Range("A" & r).Interior.Color = RGB(255, 0, 0) Then
        Rows(r).Copy Destination:=Sheets("Sheet2").Range("A" & lr2)
        lr2 = lr2 + 1
    End If
    If Range("A" & r).Interior.Color = RGB(0, 176, 80) Then
        Rows(r).Copy Destination:=Sheets("Sheet3").Range("A" & lr3)
        lr3 = lr3 + 1
    End If
    Range("A1").Select
Next r
End Sub
 
Upvote 0
try this:
VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim lr As Long, lr2 As Long, r As Long
lr = Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
'lr2 = Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Row
lr2 = 2
'lr3 = Sheets("Sheet3").Cells(Rows.Count, "A").End(xlUp).Row
lr3 = 2
Sheet2.Range("A1").CurrentRegion.Offset(1).ClearContents
Sheet3.Range("A1").CurrentRegion.Offset(1).ClearContents

For r = 2 To lr
    If Range("A" & r).Interior.Color = RGB(255, 0, 0) Then
        Rows(r).Copy Destination:=Sheets("Sheet2").Range("A" & lr2)
        lr2 = lr2 + 1
    End If
    If Range("A" & r).Interior.Color = RGB(0, 176, 80) Then
        Rows(r).Copy Destination:=Sheets("Sheet3").Range("A" & lr3)
        lr3 = lr3 + 1
    End If
    Range("A1").Select
Next r
End Sub
Yep that did it! Thank you!
 
Upvote 0
Actually my apologies I preemptively celebrated. I ran a test and it appears that not all data gets cleared from sheets2/3. If I change a cell on sheet 1 from red to green, or vice versa, then an empty red or green cell remains on the respective sheet.
 
Upvote 0

Forum statistics

Threads
1,213,510
Messages
6,114,040
Members
448,543
Latest member
MartinLarkin

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top