Copy entire row from current sheet to another sheet on color basis

Question

My current sheet is having data in which few cells having Green color, i need to move or copy those rows in which cell having green colour (only few cells coloured with green)to another sheet. i have written code for that but the loop runs on first column for each row wise but wont checks for every cell in that row. i need to check for every row each cell if any cell in green colour then it should copy and paste the entire row in another sheet on next row

Sub Copy()

lastRow = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row

sheet2Counter = 1

For i = 1 To lastRow

ConditionalColor = Worksheets("Sheet1").Cells(i, 1).Interior.ColorIndex

Worksheets("Sheet1").Activate
Worksheets("Sheet1").Range("A" & i & " ").Select

If ConditionalColor = 35 Then
ActiveCell.EntireRow.copy
Worksheets("Sheet2").Activate

lastrow1 = Worksheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row
If Not Worksheets("Sheet2").Range("A" & lastrow1 & " ") = "" And Not i = 1 Then
lastrow1 = lastrow1 + 1
Worksheets("Sheet2").Range("A" & lastrow1 & " ").Select

    With Selection
        .PasteSpecial Paste:=xlPasteAll
    End With
Else
Worksheets("Sheet2").Range("A1").Select

    With Selection
        .PasteSpecial Paste:=xlPasteAll
    End With

End If

Worksheets("Sheet1").Cells(i, 1).Value

End If

Next

End Sub

Are these cells colored with conditional formatting? Because .Cells(i, 1).Interior.ColorIndex will not detect conditional formatting. You can use the DisplayFormat , i.e. .Cells(i, 1).DisplayFormat.Interior.ColorIndex for that. — BigBen
but this will detect the color which i need.. as per my req i need 35 index color and it working well.. but issue here is im able to do this for every row in first column but not every cell in that particular row. i want to copy entire row if any cell of each row is having color index 35 and paste into another sheet — harsha kazama
Ok then you are not using conditional formatting - it's just unclear from the name ConditionalColor. — BigBen
yes im not using conditional formatting coz im very poor in formulas.. so i never tried. but written few lines of VBA code which works for 1st column for every row. — harsha kazama
Using ColorIndex is bad idea, since it can change based on the theme you're using. Use the RGB value instead. — Frank Ball

Tim Williams Tim Williams · Accepted Answer · 2018-10-30T00:15:40

You can do something like this:

Option Explicit

Sub CopyByColor()

    Dim shtSrc As Worksheet, shtDest As Worksheet
    Dim lastRowSrc As Long, nextRowDest As Long, i As Long

    Set shtSrc = Worksheets("Sheet1")
    Set shtDest = Worksheets("Sheet2")

    lastRowSrc = shtSrc.Cells(Rows.Count, 1).End(xlUp).Row
    nextRowDest = shtDest.Cells(Rows.Count, 1).End(xlUp).Row + 1

    For i = 1 To lastRowSrc
        'only check used cells in the row...
        If IsColorMatch(Application.Intersect(shtSrc.Rows(i), shtSrc.UsedRange)) Then
            shtSrc.Rows(i).Copy shtDest.Cells(nextRowDest, 1)
            nextRowDest = nextRowDest + 1
        End If
    Next i

End Sub

Function IsColorMatch(rng As Range)
    Const INDEX_COLOR As Long = 35
    Const INDEX_COLOR_BAD As Long = 3 'or whatever...
    Dim c As Range, indx

    IsColorMatch = False '<< default

    For Each c In rng.Cells
        indx = c.Interior.ColorIndex
        If indx = INDEX_COLOR Then
            IsColorMatch = True
        Elseif indx = INDEX_COLOR_BAD Then
            IsColorMatch = False
            Exit Function '<< got a "bad" color match, so exit
        End If
    Next c

End Function

EDIT: a different implementation of IsColorMatch using the "find formatting" approach:

Function IsColorMatch(rng As Range) As Boolean
    If RangeHasColorIndex(Selection.EntireRow, 6) Then
        IsColorMatch = Not RangeHasColorIndex(Selection.EntireRow, 3)
    Else
        IsColorMatch = False
    End If
End Function

Function RangeHasColorIndex(rng As Range, indx As Long)
    With Application.FindFormat
        .Clear
        .Interior.ColorIndex = indx
    End With
    RangeHasColorIndex = Not rng.Find("", , , , , , , , True) Is Nothing
End Function

Copy entire row from current sheet to another sheet on color basis

1 Answers