Macro to Copy Coloured Data on "Import Templates last updated" created by CF

[Howardc1001]

I have the following Code below to copy data that is coloured in Cols A1 to last row in Col D on sheets "Import Templates last updated" created by CF
and paste these on sheets "Reports Ready for checking"


When running the code, the data in the last row in Col D and E is being removed

Kindly test and amend my code that this does not happen

 sub CopyImportTemplatesUpdated()
    Dim importSheet As Worksheet
    Dim reportSheet As Worksheet
    Dim importRange As Range
    Dim cell As Range
    Dim lastRow As Long
    Dim startColumn As Long
    Dim j As Long

    ' Set the source and destination sheets
    Set importSheet = ThisWorkbook.Sheets("Import Templates last updated")
    Set reportSheet = ThisWorkbook.Sheets("Reports Ready for checking")

    ' Find the last row in column C of the source sheet
    lastRow = importSheet.Cells(importSheet.Rows.Count, "C").End(xlUp).Row

    ' Set the range to the columns A to C in the source sheet
    Set importRange = importSheet.Range("A1:C" & lastRow)
    startColumn = importRange.Columns(1).Column ' Get the starting column index

    ' Clear A1 to the last row in Column C in the destination sheet
    reportSheet.Range("A1:C" & reportSheet.Rows.Count).Clear

    ' Initialize a dictionary to keep track of unique rows
    Dim uniqueRows As Object
    Set uniqueRows = CreateObject("Scripting.Dictionary")

    ' Loop through each cell in the specified range
    For Each cell In importRange
        ' Check if the cell has a yellow background due to conditional formatting
        If cell.DisplayFormat.Interior.Color = RGB(255, 255, 0) Then
            ' Collect the row data in a temporary array
            Dim rowData() As Variant
            ReDim rowData(1 To 1, 1 To importRange.Columns.Count)

            ' Copy the cell values to the temporary array
            For j = 1 To importRange.Columns.Count
                rowData(1, j) = importRange.Cells(cell.Row, j).Value
            Next j

            ' Generate a key for the row
            Dim rowKey As String
            rowKey = Join(Application.Index(rowData, 1, 0), "|")

            ' Check if the row is not already added
            If Not uniqueRows.Exists(rowKey) Then
                ' Add the row to the destination sheet
                reportSheet.Range("A" & reportSheet.Rows.Count).End(xlUp).Offset(1, 0).Resize(1, UBound(rowData, 2)).Value = rowData
                ' Add the row to the dictionary to mark it as added
                uniqueRows(rowKey) = True
            End If
        End If
    Next cell

    ' Delete the first row in the destination sheet
    reportSheet.Range("A1").EntireRow.Delete

    ' Autofit columns A to C in the destination sheet
    reportSheet.Range("A:D").EntireColumn.AutoFit
    MsgBox "Templates Updated have been Copied to sheet ""Reports Ready for checking""", vbInformation
    Sheets("Reports Ready for checking").Activate
   
End Sub