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

3
votes

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
1
vbaexcel
In the sheet2 i am updating the data manually, Because when ever i get an email says payment has been received from this company i will update in the sheet2, After that i will be doing some graph. – Gyana Prakash
I should have asked: What is the issue? – QHarr
Code is running but if the data is getting matched also that row is not getting copied to sheet3. – Gyana Prakash
Here the problem is when i run this code separately it is working, but when call from another module means sheet3 remains blank and also i am not getting any error. – Gyana Prakash
I don't think the problem is Delrow per se. I suspect you are ending up working with an unexpected object due to everything that happens before. Put your worksheets and workbooks into variables. Then reference everything using those. So no Columns without a fully qualified address, no use of Activesheet etc.... You should be able to get rid of all those workbooks Activate and just use varaibles. For the shortest testing route: fully qualify everything inside of Delrow with the approrpriate workbook name(s). – QHarr

1 Answers

2
votes

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