copy rows based on cell colour

  • Thread starter Thread starter K
  • Start date Start date
K

K

Hi, can anybody please able to tell me the macro that how can i copy
rows to another sheet on based on cell colour. Like if i have
"Interior.Colorindex = 3" or Red in cell B1,B3 and B7 so how can i
copy those colored rows which should be not entire row but from Cell
A
to Cell F in length to any other sheet. Please anybody can help it
will be very helpful.... Thanks
 
Try this:

Sub test()
a = 1
b = 1
For Each cell In Range("B1:B100")
Select Case cell.Interior.ColorIndex
Case Is = 3
Range(cell.Offset(, -1), cell.Resize(, 5)).Copy _
Sheets(2).Cells(a, 1)
a = a + 1
Case Is = 37
Range(cell.Offset(, -1), cell.Resize(, 5)).Copy _
Sheets(3).Cells(b, 1)
b = b + 1
End Select
Next cell
End Sub
 
Assumes the color is not set by format conditionsl

Sub cpyColr()
Dim c As Range
lastRw = Worksheets(1).Cells(Rows.Count, 2).End(xlUp).Row
For Each c In Worksheets(1).Range("B2:B" & lastRw)
If c.Interior.ColorIndex = 3 Then
lstRw2 = Worksheets(2).Range("A65536").End(xlUp).Row
cRng = c.Address
Worksheets(1).Range("A" & Range(cRng).Row & ":F" &
Range(cRng).Row).Copy _
Worksheets(2).Range("A" & lstRw2 + 1)
End If
Next
End Sub

If cells are colored by conditional format:

Sub cpyColr()
Dim c As Range
lastRw = Worksheets(1).Cells(Rows.Count, 2).End(xlUp).Row
For Each c In Worksheets(1).Range("B2:B" & lastRw)
If c.FormatConditions(1).Interior.ColorIndex = 3 Then
lstRw2 = Worksheets(2).Range("A65536").End(xlUp).Row
cRng = c.Address
Worksheets(1).Range("A" & Range(cRng).Row & ":F" &
Range(cRng).Row).Copy _
Worksheets(2).Range("A" & lstRw2 + 1)
End If
Next
End Sub
 
I didn't get the line extension in the right place so after you paste the
code into your code module, make sure that all of this is on one line.

Worksheets(1).Range("A" & Range(cRng).Row & ":F" & _
Range(cRng).Row).Copy _
Worksheets(2).Range("A" & lstRw2 + 1)
 
Sub cpyColr()
Dim c As Range
lastRw = Worksheets(1).Cells(Rows.Count, 2).End(xlUp).Row
For Each c In Worksheets(1).Range("B2:B" & lastRw)
If c.FormatConditions.Count > 0 Then
If c.FormatConditions(1).Interior.ColorIndex = 3 Then
lstRw2 = Worksheets(2).Range("A65536").End(xlUp).Row
cRng = c.Address
Worksheets(1).Range("A" & Range(cRng).Row & ":F" & _
Range(cRng).Row).Copy Worksheets(2).Range("A" & lstRw2 + 1)
End If
End If
Next
End Sub
 
Back
Top