Need to Paste entire row from Sheet 2 to Sheet 3 if Value found in Sheet 1 A Column

Question

I have master Data in Sheet 2 (Column B) and search criteria in Sheet 1 (Column A), i want VBA to find all the data from Sheet 1 (Column A) in Sheet 2 (Column B) if found cut the entire row and past it into Sheet 3 next available row.

Sub remDup()
Dim LR As Long, LRSheet2 As Long, i As Long, a As Long
Dim vAllSheet2Values() As Variant

LRSheet2 = Worksheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row
LR = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
a = 1

For i = 1 To LRSheet2 'Load all values in ColumnA of Sheet2 into an array
    ReDim Preserve vAllSheet2Values(i)
    vAllSheet2Values(i) = Worksheets("Sheet2").Cells(i, 2).Value
Next i

For i = LR To 1 Step -1
    If IsInArray(Worksheets("Sheet1").Cells(i, 1).Value, vAllSheet2Values) Then
        Worksheets("Sheet1").Rows(i).Copy Worksheets("Sheet3").Rows(a)
        Worksheets("Sheet1").Rows(i).Delete
        a = a + 1
    End If
Next i
End Sub

Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean
    IsInArray = (UBound(Filter(arr, stringToBeFound)) > -1)
End Function

in above code data is getting deleted from sheet 1 :( and not sheet 2

Answer 1

Backup Matching Rows

• In the current setup, the code will search for all values in column A of Sheet1 in column B of Sheet2. The cells of each found value will be combined into a Total Range whose entire rows will be copied to Sheet3 (in one go) and then removed (deleted) from Sheet1 (in another go).

The Code

Option Explicit

Sub remDup()
    
    ' Constants
    Const sName As String = "Sheet1"
    Const sFirst As String = "A1"
    Const lName As String = "Sheet2"
    Const lFirst As String = "B1"
    Const dName As String = "Sheet3"
    Const dFirst As String = "A1"
    
    ' Workbook
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Source
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    Dim srg As Range: Set srg = refColumn(sws.Range(sFirst))
    If srg Is Nothing Then Exit Sub
    Dim sData As Variant: sData = getColumn(srg)
    
    ' Lookup
    Dim lws As Worksheet: Set lws = wb.Worksheets(lName)
    Dim lrg As Range: Set lrg = refColumn(lws.Range(lFirst))
    If lrg Is Nothing Then Exit Sub
    Dim lData As Variant: lData = getColumn(lrg)
    
    ' Match
    Dim trg As Range
    Dim i As Long
    For i = 1 To UBound(sData)
        If foundMatchInVector(sData(i, 1), lData) Then
            Set trg = getCombinedRange(trg, srg.Cells(i))
        End If
    Next i
            
    ' Destination
    If Not trg Is Nothing Then
        Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
        ' This is a kind of a ridiculous use of "refColumn".
        Dim drg As Range: Set drg = refColumn(dws.Range(dFirst))
        If drg Is Nothing Then
            Set drg = dws.Range(dFirst).EntireRow
        Else
            Set drg = drg.Cells(drg.Cells.Count).Offset(1).EntireRow
        End If
        trg.EntireRow.Copy drg
        trg.EntireRow.Delete
    End If

End Sub

' Assumptions:  'FirstCellRange' is a one-cell range e.g. 'Range("A1")'.
' Returns:      Either the range from 'FirstCellRange' to the bottom-most
'               non-empty cell in the column, or 'Nothing' if all cells
'               below 'FirstCellRange' (incl.) are empty.
Function refColumn( _
    ByVal FirstCellRange As Range) _
As Range
    With FirstCellRange
        Dim cel As Range
        Set cel = .Resize(.Worksheet.Rows.Count - .Row + 1) _
            .Find("*", , xlFormulas, , , xlPrevious)
        If Not cel Is Nothing Then
            Set refColumn = .Resize(cel.Row - .Row + 1)
        End If
    End With
End Function

' Assumptions:  'rg' is a one-column range e.g. 'Range("A1")', 'Range("A1:A2")'.
' Returns:      A 2D one-based one-column array.
Function getColumn( _
    rg As Range) _
As Variant
    If rg.Rows.Count > 1 Then
        getColumn = rg.Value
    Else
        Dim OneElement As Variant: ReDim OneElement(1 To 1, 1 To 1)
        OneElement(1, 1) = rg.Value
        getColumn = OneElement
    End If
End Function

' Assumptions:  'MatchValue' is a simple data type (not an object or an array).
'               'Vector' is a structure that 'Application.Match' can handle,
'               e.g. a 1D array, a one-column or one-row range or 2D array.
' Returns:      'True' or 'False' (boolean).
' Remarks:      Error values and blanks are ignored ('False').
Function foundMatchInVector( _
    ByVal MatchValue As Variant, _
    ByVal Vector As Variant) _
As Boolean
    If Not IsError(MatchValue) Then
        If Len(MatchValue) > 0 Then
            foundMatchInVector _
                = IsNumeric(Application.Match(MatchValue, Vector, 0))
        End If
    End If
End Function

' Assumptions:  'AddRange' is not 'Nothing' and it is in the same worksheet
'               as 'BuiltRange'.
' Returns:      A range (object).
Function getCombinedRange( _
        ByVal BuiltRange As Range, _
        ByVal AddRange As Range)
    If BuiltRange Is Nothing Then
        Set getCombinedRange = AddRange
    Else
        Set getCombinedRange = Union(BuiltRange, AddRange)
    End If
End Function

Answer 2

Please, try the next code:

Sub remDup()
 Dim LR As Long, LRSheet2 As Long, arr, i As Long, rngCopy As Range, rngDel As Range
 Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet, a As Long

 Set sh1 = Worksheets("Sheet1")
 Set sh2 = Worksheets("Sheet2")
 Set sh3 = Worksheets("Sheet3")

 LRSheet2 = sh2.cells(Rows.count, 2).End(xlUp).row
 LR = sh1.cells(Rows.count, 1).End(xlUp).row
 a = 1 'The Sheet3 row where the rows to be copied

 arr = sh2.Range("B1:B" & LRSheet2).Value      'put the range in a 2D array
 arr = Application.Transpose(Application.Index(arr, 0, 1)) 'obtain 1D array

 For i = 1 To LR
    If IsInArray(sh1.cells(i, 1).Value, arr) Then
        If rngCopy Is Nothing Then
            Set rngCopy = sh1.cells(i, 1) 'create a range to be copied/deleted
        Else
            Set rngCopy = Union(rngCopy, sh1.cells(i, 1))
        End If
    End If
 Next i
 rngCopy.EntireRow.Copy sh3.Range("A" & a) 'copy the range entirerow at once
 rngCopy.EntireRow.Delete                  'delete the range entirerow
End Sub

Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean
    IsInArray = UBound(Filter(arr, stringToBeFound)) > -1
End Function

Answer 3

If I'm understanding correctly this should do it. I put comments on the changed lines

Sub remDup()
Dim LR As Long, LRSheet2 As Long, i As Long, a As Long
Dim vAllSheet1Values() As Variant 'This should be referencing sheet 1 not 2

LRSheet2 = Worksheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row
LR = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
a = 1

ReDim Preserve vAllSheet1Values(LR) 'No need for this to be in a loop
For i = 1 To LR 'Load all values in ColumnA of Sheet1 into an array
    vAllSheet1Values(i) = Worksheets("Sheet1").Cells(i, 1).Value 'This should be sheet1
Next i

For i = LRSheet2 To 1 Step -1 'This and all sheet1 references after should be sheet 2
    If IsInArray(Worksheets("Sheet2").Cells(i, 1).Value, vAllSheet1Values) Then
        Worksheets("Sheet2").Rows(i).Copy Worksheets("Sheet3").Rows(a)
        Worksheets("Sheet2").Rows(i).Delete
        a = a + 1
    End If
Next i
End Sub

Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean
    IsInArray = (UBound(Filter(arr, stringToBeFound)) > -1)
End Function