根据颜色将整行从当前工作表复制到另一张工作表

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