CODEWITHSUNDEEP
excelvba
harsha kazama
harsha kazama

Reputation: 189

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

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

Upvotes: 0

Views: 1497

Answers (1)

Tim Williams
Tim Williams

Reputation: 166755

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

Upvotes: 0

Related Questions