將所有突出顯示的單元格從一張紙復制到另一張紙

Question

以前，此宏將所有帶有“灰色填充”的單元格從工作表 1 復制到工作表 2。

它開始復制並粘貼它在列中命中的第一個，而不是 rest。

新數據以空行開頭 (D2)，這會影響它嗎？

Sub copyNotFound()

    Application.ScreenUpdating = False

    Dim TransIDField As Range
    Dim TransIDCell As Range
    Dim ATransWS As Worksheet
    Dim HTransWS As Worksheet

    Set ATransWS = Worksheets("1")
    Set TransIDField = ATransWS.Range("D2", ATransWS.Range("D2").End(xlDown))
    Set HTransWS = Worksheets("2")

    For Each TransIDCell In TransIDField
        
        If TransIDCell.Interior.color = RGB(231, 230, 230) Then
                
            TransIDCell.Resize(1, 1).copy Destination:= _
              HTransWS.Range("M1").Offset(HTransWS.Rows.Count - 1, 0).End(xlUp).Offset(1, 0)
                    
        End If

    Next TransIDCell

Answer 1

使用“單元格顏色”作為標准復制數據

Option Explicit

Sub CopyMissingData()
    
    ' Workbook
    Dim wb As Workbook: Set wb = ThisWorkbook 'workbook containing this code

    ' ATrans
    Dim atws As Worksheet: Set atws = wb.Worksheets("1")
    Dim atField As Range
    With atws.Range("D2")
        Set atField = Intersect( _
            .Resize(atws.Rows.Count - .Row + 1, 1), atws.UsedRange)
    End With
    
    ' HTrans
    Dim htws As Worksheet: Set htws = wb.Worksheets("2")
    Dim htCell As Range
    Set htCell = htws.Cells(htws.Rows.Count, "M").End(xlUp).Offset(1)
    
    ' Copy
    
    Application.ScreenUpdating = False
    
    Dim atCell As Range
    
    For Each atCell In atField.Cells
        If atCell.Interior.Color = RGB(231, 230, 230) Then
            atCell.Copy Destination:=htCell
            ' You can omit 'Destination:='...
            'atCell.Copy htCell
            ' and if you want to copy more cells in a row then e.g.
            ' for columns 'D:H' instead, you could use...
            'atCell.Resize(1, 5).Copy htCell
            ' ... or for columns 'A:H' instead, you could use:
            'atCell.EntireRow.Columns("A:H").Copy htCell
            ' There is room for improvement here.
            Set htCell = htCell.Offset(1, 0) ' reference next cell (row)
        End If
    Next atCell

    Application.ScreenUpdating = True
    
    ' Inform.
    MsgBox "Missing data copied.", vbInformation

End Sub