Macro that copy and pastes all highlighted cells from one sheet to another

user_18305410 0
Viewed 92

I have this macro that copies all cells with a 'grey fill' from sheet 1 to sheet 2.

It's suddenly only started copying and pasting the first one it hits in a column, not the rest.

Can anyone spot why this is happening?

In the new data I'm checking, the data starts (D2) with an empty row, could this be affecting it?

Thanks for any input.

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
vba excel
1 Answers

Copy Data Using 'Cell Color' As Criteria

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
user_98140690
Related