Compare cells value in sheet1 and sheet2 then move entire row to sheet3

Question

I have three sheets like "Sheet1", "Sheet2" and "Sheet3".

"Sheet1" is having the raw data. In "Sheet2" I have all the payment received data with company's name in the Column A. I am having the company name in "Sheet1" Column B.

Here what I am trying to do is as soon as I received the raw data if any company name matches in "Sheet1", I am moving that entire row to "Sheet3". I also wrote the following code, but is not working properly:

Sub RowFinder()
Dim sheet1Data As Variant

With Worksheets("Sheet2") '<--| reference your worksheet 2
    sheet1Data = Application.Transpose(.Range("A1", .Cells(.Rows.Count, 1).End(xlUp)).Value)
End With
With Worksheets("Sheet1") '<--| reference your worksheet 1
    With .Range("B2", .Cells(.Rows.Count, "B").End(xlUp)) '<--| reference its column A cells from row 1 (header) down to last not empty one
        .AutoFilter field:=1, Criteria1:=sheet1Data, Operator:=xlFilterValues '<--| filter cells with sheet 2 column A values
        If Application.WorksheetFunction.Subtotal(103, .Cells) > 1 Then Intersect(.Parent.UsedRange, .Resize(.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible).EntireRow).Copy Destination:=Worksheets("Sheet3").Range("A1")
    End With
    .AutoFilterMode = False
End With
End Sub

Can someone please help on this issue? Thanks.

---

Here is the complete code.

Sub Vlookup()

Windows("Contract Report v1.2.xlsm").Activate
Worksheets("Contract Details").Activate
Columns("A:C").Select
Selection.Copy
Windows("Contract Reports.xls").Activate
With ActiveWorkbook
    .Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = "Sheet2"
End With
Worksheets("Sheet2").Activate
ActiveSheet.Paste
Application.CutCopyMode = False
Worksheets("Sheet1").Activate

' Column D = "SoW#"
lastRow = Range("B" & Rows.Count).End(xlUp).Row
Range("D2").FormulaR1C1 = "=VLOOKUP(RC[-2],Sheet2!C[-3]:C[-1],2,0)"
Range("D2").AutoFill Destination:=Range("D2:D" & lastRow), 
Type:=xlFillDefault
Sheets("Sheet1").Columns(4).Copy
Sheets("Sheet1").Columns(4).PasteSpecial xlPasteValues
Columns("D").Select
On Error Resume Next
Cells.Replace What:="#N/A", Replacement:="Not Yet Defined", LookAt:=xlPart, SearchOrder _
:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False

' Column E = "Service Line"
lastRow = Range("B" & Rows.Count).End(xlUp).Row
Range("E2").FormulaR1C1 = "=VLOOKUP(RC[-3],Sheet2!C[-4]:C[-2],3,0)"
Range("E2").AutoFill Destination:=Range("E2:E" & lastRow), Type:=xlFillDefault
Sheets("Sheet1").Columns(5).Copy
Sheets("Sheet1").Columns(5).PasteSpecial xlPasteValues
Columns("E").Select
On Error Resume Next
Cells.Replace What:="#N/A", Replacement:="Not Yet Defined", LookAt:=xlPart, SearchOrder _
:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False

Application.DisplayAlerts = False
Sheets("Sheet2").Delete
Application.DisplayAlerts = True
Worksheets("Sheet1").Activate

Columns("D:E").EntireColumn.AutoFit
Columns("D:E").HorizontalAlignment = xlCenter
Range("A1").Select
Selection.AutoFilter
ActiveSheet.Range("$A$1:$AQ$1").AutoFilter field:=12, Criteria1:="Yes"
Columns("D:E").EntireColumn.AutoFit
Columns("D:E").HorizontalAlignment = xlCenter

Range("A1:A10000") = Evaluate("IF(LEN(A1:A10000),A1:A10000,B1:B10000)")
Range("B:B").SpecialCells(xlCellTypeBlanks).EntireRow.Delete

ActiveWorkbook.Save

Application.ScreenUpdating = False

ColAry = Array("Owner's Email", "BFM Name", "Contract Currency4", "Contract Value4", "Contract Currency5", "Contract Value5")

With Sheets("Sheet1")
For z = LBound(ColAry) To UBound(ColAry)
fc = 0
On Error Resume Next
fc = Application.Match(ColAry(z), .Rows(1), 0)
On Error GoTo 0
If fc > 0 Then
  .Columns(fc).Delete
End If
Next z
End With

With Sheets("Sheet1")
Set SrchRng = ActiveSheet.Range("B2", ActiveSheet.Range("B65536").End(xlUp))
Do
    Set c = SrchRng.Find("A", LookIn:=xlValues)
    If Not c Is Nothing Then c.EntireRow.Delete
Loop While Not c Is Nothing
Range("A1").Select
End With

Application.ScreenUpdating = True
ActiveWorkbook.Save

'All the below mentioned contract id's will be shown as "Ignore" under status column.

With ActiveWorkbook
.Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = "Ignore"
End With

With ActiveWorkbook
.Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = "Sheet3"
End With

Windows("Contract Report v1.2.xlsm").Activate
Worksheets("Ignore").Activate
Columns("A").Copy
Windows("Contract Reports.xls").Activate
Worksheets("Ignore").Activate
Range("A1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Range("A1").Select
Call Delrow
End Sub

Sub Delrow()

'--- The below code will move all the Ignore contract to another sheet ------

With Worksheets("Ignore") '<--| reference your worksheet 2
    sheet1Data = Application.Transpose(.Range("A1", .Cells(.Rows.Count, 1).End(xlUp)).Value)
End With
With Worksheets("Sheet1") '<--| reference your worksheet 1
    With .Range("B2", .Cells(.Rows.Count, "B").End(xlUp)) '<--| reference its column A cells from row 1 (header) down to last not empty one
        .AutoFilter field:=1, Criteria1:=sheet1Data, Operator:=xlFilterValues '<--| filter cells with sheet 2 column A values
        If Application.WorksheetFunction.Subtotal(103, .Cells) > 1 Then Intersect(.Parent.UsedRange, .Resize(.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible).EntireRow).Copy Destination:=Worksheets("Sheet3").Range("A1")
    End With
    .AutoFilterMode = False
End With
MsgBox "Done"
End Sub

Answer 1

You could use an array of values to filter a range, cut the filtered range and move it to another sheet. BUt this pattern is so much easier to implement.

• Use a Collection to store the values to be match
• Iterate for the rows to match Note: Always go last element to first element when deleting/cutting
• Cut/Move match row using Entirerow.Cut Destination:=Destination

---

Sub MatchValues()
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    Dim c As Range, list As Object
    Dim r As Long
    Set list = CreateObject("System.Collections.ArrayList")

    With Worksheets("Sheet2")
        For Each c In .Range("A1", .Cells(.Rows.Count, 1).End(xlUp))
            If c.Value <> "" And Not list.Contains(c.Value) Then list.Add c.Value
        Next
    End With

    With Worksheets("Sheet1")
        For r = .Cells(.Rows.Count, "B").End(xlUp).Row To 2 Step -1
            If list.Contains(.Cells(r, "B").Value) Then
                MoveRow .Rows(r)
            End If
        Next
    End With
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

Sub MoveRow(Target As Range)
    Dim lastow As Long
    With Worksheets("Sheet3").Cells
        If WorksheetFunction.CountA(.Cells) = 0 Then
            LastRow = 1 
        Else 
               lastRow = .Find(What:="*", After:=.Cells(1), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row
        End If
        Target.EntireRow.Cut .Rows(lastRow + 1)
    End With

End Sub