Copy and paste multiple matching rows to a new sheet

[Multim]

Hi Newbie to VBA here

I have a list of part numbers in a sheet called Review in column A (with a header line in A1)

This list can be from 20 to 100+ part numbers long.

These part numbers will match a master list with multiple entries in a sheet called Master column C (with a header line in row 1).

I would like a VBA code to search all of the part numbers from the sheet called Review from A2 down to the last part number and copy and paste all matching rows from the sheet called Master into a new sheet including the header line in row 1.

I have search but can not find a way to do this, can anyone help please.

 

[awoohaw]

Can you post a small sample of both sets of data? please use the xl2bb tool if you can (link in editing bar, and in the signature box below). If you cannot use that, then post your data in a table (copy and paste cells from your worksheets). Do not post an image as the forum needs to completely recreate your scenario that way.

Are you open to VBA solutions?

PS Welcome to the forum.

 

[Multim]

Hi awoohaw

VBA would be preferred please

Samples copied & pasted below

Master Worksheet

GRN No

Line No

Part No

Description

Group Code

Category

Location

Qty Left

UOM

UOP

Unit Of Conv

Status ID

Status

blnShowInDropdown

Lifed Item

10922​

1​

RP010001

SR-30 SOLUBLE RELEASE SUPPORT CANISTER FORTUS PLUS 0355-03110 - 450

3D PRINTING

G5A

1​

EA

EA

1​

1​

Live

TRUE​

FALSE​

10676​

1​

RP010001

SR-30 SOLUBLE RELEASE SUPPORT CANISTER FORTUS PLUS 0355-03110 - 450

3D PRINTING

G5A

5​

EA

EA

1​

1​

Live

TRUE​

FALSE​

10676​

2​

RP010002

ABS-M30 FILAMENT CANISTER FORTUS PLUS NATURAL 0355-02110

3D PRINTING

G6A

6​

EA

EA

1​

1​

Live

TRUE​

FALSE​

7307​

1​

RP010002

ABS-M30 FILAMENT CANISTER FORTUS PLUS NATURAL 0355-02110

3D PRINTING

G6A

2​

EA

EA

1​

1​

Live

TRUE​

FALSE​

1003​

1​

RP010003

ABS-M30 FILAMENT CANISTER FORTUS PLUS BLACK 0355-02112

3D PRINTING

G7A

1​

EA

EA

1​

1​

Live

TRUE​

FALSE​

1004​

1​

RP010004

SR-30 SUPPORT CARTRIDGE (FORTUS 250MC) 0340-30500

3D PRINTING

G8A

5​

EA

EA

1​

1​

Live

TRUE​

FALSE​

1005​

1​

RP010005

P430 DIMENSION ABS PLUS MATERIAL CASSETTE WHITE 0340-21201

3D PRINTING

G9A

8​

EA

EA

1​

1​

Live

TRUE​

FALSE​

4994​

5​

RP010006

FOUNDATION SHEET SMALL FORTUS 450/900MC 0325-00275

3D PRINTING

G7B

60​

EA

PK

20​

1​

Live

TRUE​

FALSE​

1007​

1​

RP010007

ULTEM 1010 MODEL FORTUS 450MC NATURAL 0355-02330

3D PRINTING

G10A

3​

EA

EA

1​

1​

Live

TRUE​

FALSE​

1008​

1​

RP010008

ULTEM 1010 SUPPORT FORTUS 450MC NATURAL 0355-03240

3D PRINTING

G11A

4​

EA

EA

1​

1​

Live

TRUE​

FALSE​

1009​

1​

RP010011

ABS-M30I FILAMENT CANISTER FORTUS PLUS NATURAL 0355-02120

3D PRINTING

G12A

3​

EA

EA

1​

1​

Live

TRUE​

FALSE​

6606​

1​

AB010001

ABRANET DISC 150MM P80

ABRASIVES

E3A

1​

box

box

1​

1​

Live

TRUE​

FALSE​

4273​

3​

AB010001

ABRANET DISC 150MM P80

ABRASIVES

E3A

2​

box

box

1​

1​

Live

TRUE​

FALSE​

Review Worksheet

Part No

RP010001

RP010002

RP010003

RP010004

RP010005

RP010006

RP010007

RP010008

RP010011

AB010001

AB010002

AB010003

AB010005

AB010006

AB010012

AB010013

AB010016

AB010017

 

[Alex Blakenburg]

See if this does what you need:

Sub CopyPartsForReview()

    Dim wb As Workbook
    Dim shtMaster As Worksheet, shtReview As Worksheet, shtOut As Worksheet
    Dim rowLastMstr As Long, rowLastRev As Long
    Dim rngMstr As Range, rngRev As Range
    Dim arrMstr As Variant, arrRev As Variant, arrOut As Variant
    Dim dictRev As Object, dictKey As String
    Dim i As Long, j As Long, rowOut As Long
    
    Set wb = ActiveWorkbook
    Set shtMaster = wb.Worksheets("Master")
    Set shtReview = wb.Worksheets("Review")
    
    With shtMaster
        rowLastMstr = .Range("C" & Rows.Count).End(xlUp).Row
        Set rngMstr = .Range("A1:O" & rowLastMstr)
        arrMstr = rngMstr.Value2
    End With
    
    ReDim arrOut(1 To UBound(arrMstr, 1), 1 To UBound(arrMstr, 2))
    
    With shtReview
        rowLastRev = .Range("A" & Rows.Count).End(xlUp).Row
        Set rngRev = .Range("A2:A" & rowLastRev)
        arrRev = rngRev.Value2
    End With
    
    Set dictRev = CreateObject("Scripting.dictionary")
    dictRev.CompareMode = vbTextCompare
    
    ' Review Parts into Dictionary
    For i = 1 To UBound(arrRev)
        dictKey = arrRev(i, 1)
        If Not dictRev.exists(dictKey) Then
            dictRev(dictKey) = i
        End If
    Next i

    For i = 2 To UBound(arrMstr)
        dictKey = arrMstr(i, 3)
        If dictRev.exists(dictKey) Then
            rowOut = rowOut + 1
            For j = 1 To UBound(arrMstr, 2)
                arrOut(rowOut, j) = arrMstr(i, j)
            Next j
        End If
    Next i
    
    If rowOut > 0 Then
        With wb
            Set shtOut = .Sheets.Add(After:=.Worksheets(.Worksheets.Count))
        End With
        
        With shtOut
            rngMstr.Rows(1).Copy Destination:=.Range("A1")
            .Range("A2").Resize(rowOut, UBound(arrOut, 2)).Value = arrOut
            .Columns("A").Resize(, UBound(arrOut, 2)).AutoFit
        End With
    End If
    
End Sub

 

[Multim]

Thank you Alex

This works perfectly

If I wanted to extend the copy range to column "x" can i modify this line like this - Set rngMstr = .Range("A1:X" & rowLastMstr) ?

 

[Alex Blakenburg]

Glad to hear it.
Yes definitely, just change it to whatever your end column is.

 

[Multim]

Brilliant Alex, thanks for your help.

 

[SamKhem]

See if this does what you need:

Sub CopyPartsForReview()

    Dim wb As Workbook
    Dim shtMaster As Worksheet, shtReview As Worksheet, shtOut As Worksheet
    Dim rowLastMstr As Long, rowLastRev As Long
    Dim rngMstr As Range, rngRev As Range
    Dim arrMstr As Variant, arrRev As Variant, arrOut As Variant
    Dim dictRev As Object, dictKey As String
    Dim i As Long, j As Long, rowOut As Long
   
    Set wb = ActiveWorkbook
    Set shtMaster = wb.Worksheets("Master")
    Set shtReview = wb.Worksheets("Review")
   
    With shtMaster
        rowLastMstr = .Range("C" & Rows.Count).End(xlUp).Row
        Set rngMstr = .Range("A1:O" & rowLastMstr)
        arrMstr = rngMstr.Value2
    End With
   
    ReDim arrOut(1 To UBound(arrMstr, 1), 1 To UBound(arrMstr, 2))
   
    With shtReview
        rowLastRev = .Range("A" & Rows.Count).End(xlUp).Row
        Set rngRev = .Range("A2:A" & rowLastRev)
        arrRev = rngRev.Value2
    End With
   
    Set dictRev = CreateObject("Scripting.dictionary")
    dictRev.CompareMode = vbTextCompare
   
    ' Review Parts into Dictionary
    For i = 1 To UBound(arrRev)
        dictKey = arrRev(i, 1)
        If Not dictRev.exists(dictKey) Then
            dictRev(dictKey) = i
        End If
    Next i

    For i = 2 To UBound(arrMstr)
        dictKey = arrMstr(i, 3)
        If dictRev.exists(dictKey) Then
            rowOut = rowOut + 1
            For j = 1 To UBound(arrMstr, 2)
                arrOut(rowOut, j) = arrMstr(i, j)
            Next j
        End If
    Next i
   
    If rowOut > 0 Then
        With wb
            Set shtOut = .Sheets.Add(After:=.Worksheets(.Worksheets.Count))
        End With
       
        With shtOut
            rngMstr.Rows(1).Copy Destination:=.Range("A1")
            .Range("A2").Resize(rowOut, UBound(arrOut, 2)).Value = arrOut
            .Columns("A").Resize(, UBound(arrOut, 2)).AutoFit
        End With
    End If
   
End Sub

Dear Alex, could I ask you if I need to matching from multi sheet such as master, master1, master2, master3 sheets. How would you vba code change?