Excel compare and move

Hi All,

I need a bit of excel help. I'm trying to compare part numbers in Column B to part numbers in Column A, If part numbers in column B do NOT exist in A then move Cell B and C content to new sheet.

Row 1 has Labels for columns.

I would really appreciate some help.
Who is Participating?
dlmilleConnect With a Mentor Commented:
App compares data in column B with column A using countif formula in temporary column IS.  When B doesn't match a, it is copied with column C to new sheet called "Output" and marked for deletion.  At the end, column B:C no match rows are deleted, shifting the cells up as part of the process:

Option Explicit

Sub comparePartsAndMove()
Dim wkb As Workbook
Dim wks As Worksheet
Dim wksOut As Worksheet
Dim r As Range
Dim chkRange As Range
Dim rngA As Range
Dim rngB As Range
Dim lastRow As Long
Dim i As Long
Dim vHeader As Variant
Dim rDelete As Range

Application.ScreenUpdating = False

    Set wkb = ThisWorkbook
    Set wks = wkb.ActiveSheet
    On Error Resume Next
    Set wksOut = wkb.Sheets("Output")
    If Err.Number = 0 Then
        Set wksOut = wkb.Sheets.Add(after:=wkb.Sheets(wks.Name))
        wksOut.Name = "Output"
    End If
    On Error GoTo 0
    vHeader = Application.Transpose(Application.Transpose(wks.Range("B1:C1")))
    wksOut.Range("A1").Resize(1, UBound(vHeader)).Value = vHeader
    lastRow = wks.Range("B" & wks.Rows.Count).End(xlUp).Row
    Set rngA = wks.Range("A2", wks.Range("A" & wks.Rows.Count).End(xlUp))
    Set rngB = wks.Range("B2", wks.Range("B" & wks.Rows.Count).End(xlUp))
    Set chkRange = wks.Range("IS2:IS" & lastRow) 'some column far to the right
    chkRange.Formula = "=COUNTIF(" & rngA.Address & ",$B2)"
    chkRange.Value = chkRange.Value
    i = 0
    For Each r In wks.Range("IS2:IS" & lastRow)
        If r.Value = 0 Then 'not found in column A
            If rDelete Is Nothing Then
                Set rDelete = wks.Range("B" & r.Row & ":C" & r.Row)
                Set rDelete = Union(rDelete, wks.Range("B" & r.Row & ":C" & r.Row))
            End If
            wks.Range("B" & r.Row & ":C" & r.Row).Copy
            wksOut.Range("A2").Offset(i, 0).PasteSpecial
            Application.CutCopyMode = False
            i = i + 1
        End If
    Next r
    'clean up
    'delete the rows to complete the move
    If Not rDelete Is Nothing Then rDelete.Delete shift:=xlUp
    MsgBox "Process Complete, hit enter to see results", vbOKOnly, "Success!"
Application.ScreenUpdating = True

End Sub

Open in new window

See attached.


bcontentAuthor Commented:
Hi dlmille,

Wow, you are amazing. Your solution worked Great. I was able to follow it clearly. The sample file really helped.

Thank you so much.
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.