Скопировать всю строку с текущего листа на другой лист на основе цвета

Question

В моем текущем листе есть данные, в которых несколько ячеек зеленого цвета, мне нужно переместить или скопировать те строки, в которых ячейка зеленого цвета (только несколько ячеек зеленого цвета), на другой лист. Я написал код для этого, но цикл выполняется в первом столбце для каждой строки, но не проверяет для каждой ячейки в этой строке. мне нужно проверить для каждой строки каждой ячейки, если какая-либо ячейка зеленого цвета, то она должна скопировать и вставить всю строку в другой лист на следующую строку

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

Answer 1

Вы можете сделать что-то вроде этого:

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

РЕДАКТИРОВАТЬ : другая реализация IsColorMatch с использованием подхода "найти форматирование":

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