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

将整个行从当前工作表复制到另一工作表（按颜色）

1 个答案: