复制所有数据行将颜色填充到新工作表

Question

我有一个冗长的电子表格，一直在更新。任务完成后，数据行将以标准颜色绿色填充。我希望能够编写一个宏，它可以从当前工作表中获取所有用绿色填充的行，并将它们粘贴到新工作表上？有任何想法吗？

如果这有帮助，行号不是常数，它们总是在变化。填充绿色的行数并不总是相同。

Answer 1

也许您可以根据自己的要求修改以下代码。

Sub CopyGreenColoredRows()
Dim wsSource As Worksheet, wsDest As Worksheet
Dim i As Long, lr As Long, lc As Long, dlr As Long

Application.ScreenUpdating = False

Set wsSource = Sheets("Sheet1") 'Source sheet with colored rows/Sheet to copy data from
Set wsDest = Sheets("Sheet2")   'Destination Sheet/copy the data to

'Clearing the destination sheet excluding headers before pasting new data
'Remove this line if not required
wsDest.UsedRange.Offset(1).Clear

lr = wsSource.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
lc = wsSource.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column

With wsSource
    'Assuming Row1 is the header row
    For i = 2 To lr
        'The code assumes that the color applied is through the conditional formatting
        If .Range("A" & i).DisplayFormat.Interior.Color = 5287936 Then
            dlr = wsDest.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
            .Range("A" & i, .Cells(i, lc)).Copy wsDest.Range("A" & dlr)
        End If
    Next i
End With
Application.ScreenUpdating = True
End Sub

Answer 2

以下代码执行您所描述的内容。请注意，在动画.gif中，Sheet2从空白处开始，然后在运行时，只复制绿色行。当然，您需要根据具体情况进行修改。

Option Explicit
Sub transferGreen()
Dim sourceSh As Worksheet, destSh As Worksheet
Dim cell As Range, sourceR As Range, destR As Range
Set sourceSh = Worksheets("Sheet1")
Set sourceR = sourceSh.Range("A1")
Set sourceR = sourceSh.Range(sourceR, sourceR.End(xlDown))
Set destSh = Worksheets("Sheet2")
Set destR = destSh.Range("A1")
If destR.Offset(1, 0) <> "" Then Set destR = destR.End(xlDown).Offset(1, 0)
sourceR.Select
destSh.Activate
For Each cell In sourceR
  If cell.Interior.Color = 5287936 Then
    sourceSh.Rows(cell.row).Copy
    destSh.Rows(destR.row).Select
    destSh.Paste
    Set destR = destR.Offset(1, 0)
  End If
Next
End Sub