Copy Data From Sheet to Another Sheet If It Is Not Found

Question

I have this issue with existing code. This code works perfectly fine to read column A (Number data type).

What the code do:

1. Read Column A from Sheet 2024 & Column A from Sheet UPDATE
2. If number in column A sheet UPDATE is not found in sheet 2024, then copy that row to Sheet HIDE.
3. If number in column A sheet UPDATE is found in sheet 2024, then do nothing.

       Dim Cl As Range, Rng As Range
       Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
       'copy row yang ada di sheets 2 tapi gaada di sheets 1 ke sheets 3
       
       Set ws1 = ThisWorkbook.Sheets("2024")
       Set ws2 = ThisWorkbook.Sheets("UPDATE")
       Set ws3 = ThisWorkbook.Sheets("HIDE")
       With CreateObject("scripting.dictionary")
          For Each Cl In ws1.Range("A2", ws1.Range("A" & Rows.Count).End(xlUp))
             .Item(Cl.Value) = Empty
          Next Cl
          For Each Cl In ws2.Range("A2", ws2.Range("A" & Rows.Count).End(xlUp))
             If Not .exists(Cl.Value) Then
                If Rng Is Nothing Then Set Rng = Cl Else Set Rng = Union(Rng, Cl)
             End If
          Next Cl
       End With
       If Not Rng Is Nothing Then
          Rng.EntireRow.Copy ws3.Range("A" & Rows.Count).End(xlUp)
       End If

But, i think it has problem to match column A when it contains text data type because it didn't give any result. Could anyone please give any idea to solve this? Thank you very much :)

Answer 1

Copy Mismatching Rows

Slow - Educational

Sub CopyMismatchingRowsEDU()
    
    ' If a value in the source sheet is not found in the lookup sheet,
    ' copies the entire row of the source sheet to the destination sheet.

    ' Workbook
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Lookup
    Dim lws As Worksheet: Set lws = wb.Sheets("2024")
    Dim lrg As Range:
    Set lrg = lws.Range("A2", lws.Cells(lws.Rows.Count, "A").End(xlUp))
    
    ' Source
    Dim sws As Worksheet: Set sws = wb.Sheets("Update")
    Dim srg As Range:
    Set srg = sws.Range("A2", sws.Cells(sws.Rows.Count, "A").End(xlUp))
    
    ' Destination
    Dim dws As Worksheet: Set dws = wb.Sheets("Hide") ' destination
    ' The destination cell has to be in column 1 ('A') when copying entire rows.
    ' '.EntireRow.Columns(1)' ensures this even if you decide to reference
    ' the (first available) cell in another column.
    Dim dfcell As Range: Set dfcell = dws.Range("A2", _
        dws.Cells(dws.Rows.Count, "A").End(xlUp)).Offset(1).EntireRow.Columns(1)
    
    ' Declare additional variables.
    Dim surg As Range, cell As Range, Value As Variant, vString As String
    
    With CreateObject("Scripting.Dictionary") ' reference a dictionary
        .CompareMode = vbTextCompare ' i.e. 'A = a'
        ' Return the distinct values from the lookup range
        ' in (the keys of) the dictionary excluding errors and blanks.
        For Each cell In lrg.Cells
            Value = cell.Value
            If Not IsError(Value) Then ' is no error
                vString = CStr(Value)
                If Len(vString) > 0 Then ' is not blank
                    If Not .Exists(vString) Then ' prevent overwriting
                        .Item(vString) = Empty
                    End If
                End If
            End If
        Next cell
        ' Combine the source cells whose values are not contained
        ' in the dictionary into the unioned range excluding errors and blanks.
        For Each cell In srg.Cells
            Value = cell.Value
            If Not IsError(Value) Then ' is no error
                vString = CStr(Value)
                If Len(vString) > 0 Then ' is no blank
                    If Not .Exists(vString) Then
                        If surg Is Nothing Then
                            Set surg = cell
                        Else
                            Set surg = Union(surg, cell)
                        End If
                    End If
                End If
            End If
        Next cell
    End With
    
    ' Copy the entire rows of the unioned range to the destination sheet.
    If Not surg Is Nothing Then
        surg.EntireRow.Copy dfcell
    End If

End Sub

Fast (Application.Match)

Sub CopyMismatchingRows()
    
    ' If a value in the source sheet is not found in the lookup sheet,
    ' copies the entire row of the source sheet to the destination sheet.

    ' Workbook
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Lookup
    Dim lws As Worksheet: Set lws = wb.Sheets("2024")
    Dim lrg As Range:
    Set lrg = lws.Range("A2", lws.Cells(lws.Rows.Count, "A").End(xlUp))
    
    ' Source
    Dim sws As Worksheet: Set sws = wb.Sheets("Update")
    Dim srg As Range:
    Set srg = sws.Range("A2", sws.Cells(sws.Rows.Count, "A").End(xlUp))
    
    ' Destination
    Dim dws As Worksheet: Set dws = wb.Sheets("Hide") ' destination
    Dim dfcell As Range: Set dfcell = dws.Range("A2", _
        dws.Cells(dws.Rows.Count, "A").End(xlUp)).Offset(1).EntireRow.Columns(1)
    
    ' Source Row Indices (Integers and Errors)
    Dim sRowIndices As Variant: sRowIndices = Application.Match(srg, lrg, 0)
    Dim sRowsCount As Long: sRowsCount = srg.Rows.Count
    
    Dim surg As Range
    
    ' Loop through the elements (rows) of the source indices array.
    If IsArray(sRowIndices) Then
        Dim cell As Range, r As Long
        For r = 1 To UBound(sRowIndices, 1)
            If IsError(sRowIndices(r, 1)) Then
                Set cell = srg.Cells(r)
                If surg Is Nothing Then
                    Set surg = cell
                Else
                    Set surg = Union(surg, cell)
                End If
            End If
        Next cell
    Else ' the source range is a single cell
        If IsError(sRowIndices) Then
            Set surg = srg
        End If
    End If
    
    ' Check if no mismatches.
    If surg Is Nothing Then
        MsgBox "No mismatches found!", vbExclamation
        Exit Sub
    End If
    
    ' Copy the entire rows of the unioned range to the destination sheet.
    surg.EntireRow.Copy dfcell
 
    ' Inform.
    MsgBox "Mismatching rows copied.", vbInformation

End Sub