Search a each value from a column of sheet in another sheet's column and if find then paste entire row in output

Question

I'm new to this so please help me. I have a workbook with below three sheets-

Sheet1- Has 3 cloumns- A,B,C Sheet2- Has One Column- A **Ouput

If Value in a cell of Sheet1- Column B matches with value in any cell of Sheet2 Column A then copy that entire row and paste to next available blank row (starts from column A) of output sheet.

column B of sheet 2 can have duplicate cells and all the matched cells should go to next available row of output sheet.

**Sheet 1**                 **Sheet 2**                   **Output**
A    B     C                  A                          3    Glen   28
1    Jen   26                Glen                        1    Jen   26  
2    Ben   24                Jen                         4    Jen   18
3    Glen  28
4    Jen   18

I tried below. Not sure how good it is-

Sub Test()        
    Set objwork1 = ActiveWorkbook ' Workbooks("Search WR")
    Set obj1 = objwork1.Worksheets("Header")
    Set obj2 = objwork1.Worksheets("XML1")
    Set obj3 = objwork1.Worksheets("VC")
    Set obj4 = objwork1.Worksheets("Output")

    i = 2
    j = 2

    Do Until (obj3.Cells(j, 1)) = ""
        If obj2.Cells(i, 2) = obj3.Cells(j, 1) Then
            Set sourceColumn = obj2.Rows(i)
            Set targetColumn = obj4.Rows(j)
            sourceColumn.Copy Destination:=targetColumn
        Else
            i = i + 1
        End If

        j = j + 1
    Loop
End Sub

Tried below as well-

Sub Check()
    Set objwork1 = ActiveWorkbook ' Workbooks("Search WR")
    Set obj1 = objwork1.Worksheets("Header")
    Set obj2 = objwork1.Worksheets("XML1")
    Set obj3 = objwork1.Worksheets("VC")
    Set obj4 = objwork1.Worksheets("Output")

    Dim LR As Long, i As Long, j As Long
    j = 2
        LR = Range("A" & Rows.Count).End(xlUp).Row
        For i = 2 To LR
            For j = 2 To LR
            obj3.Select

            If obj3.Range("A" & i).value = obj2.Range("B" & j).value Then
                Rows(j).Select
                Selection.Copy
                obj4.Select
                obj4.Range("A1").End(xlDown).Offset(1, 0).Select

                Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                    :=False, Transpose:=False
                obj3.Select
            End If
        Next j
    Next i 
End Sub

Answer 1

Something like (assumes you are copying from first sheet. That wasn't clear).

Option Explicit

Sub test()
    Dim wb As Workbook
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim ws3 As Worksheet

    Set wb = ThisWorkbook
    Set ws1 = wb.Worksheets("Sheet1")
    Set ws2 = wb.Worksheets("Sheet2")
    Set ws3 = wb.Worksheets("Output")

    Dim currCell As Range, unionRng As Range
    'Sheet1 column B matches sheet2 column A
    With ws1
        For Each currCell In Intersect(.Range("B:B"), .UsedRange)

            If FoundInColumn(ws2, currCell, 1) Then

                If Not unionRng Is Nothing Then
                    Set unionRng = Union(unionRng, currCell.EntireRow)
                Else
                    Set unionRng = currCell.EntireRow
                End If

            End If

        Next currCell

    End With

    If Not unionRng Is Nothing Then unionRng.Copy ws3.Range("A" & IIf(GetLastRow(ws3, 1) = 1, 1, GetLastRow(ws3, 1)))

    End Sub

Public Function FoundInColumn(ByVal ws As Worksheet, ByVal findString As String, ByVal columnNo As Long) As Boolean
    Dim foundCell As Range

    Set foundCell = ws.Columns(columnNo).Find(What:=findString, After:=ws.Cells(1, columnNo), LookIn:=xlFormulas, _
                                              LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                                              MatchCase:=False, SearchFormat:=False)

    If Not foundCell Is Nothing Then FoundInColumn = True


End Function

Public Function GetLastRow(ByVal ws As Worksheet, Optional ByVal columnNumber As Long = 1) As Long

    With ws

        GetLastRow = .Cells(.Rows.Count, columnNumber).End(xlUp).Row

    End With

End Function

If it is everything from sheet2 that matches to copy then:

Option Explicit

Sub test2()

    Dim wb As Workbook
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim ws3 As Worksheet

    Set wb = ThisWorkbook
    Set ws1 = wb.Worksheets("Sheet1")
    Set ws2 = wb.Worksheets("Sheet2")
    Set ws3 = wb.Worksheets("Output")

    Dim currCell As Range, unionRng As Range
    Dim dict As Dictionary                       'tools > references > ms scripting runtime
    Set dict = New Dictionary
    'Sheet1 column B matches sheet2 column A
    With ws1

        For Each currCell In Intersect(.Range("B:B"), .UsedRange)

            If Not dict.Exists(currCell.Value) And Not IsEmpty(currCell) Then

                dict.Add currCell.Value, currCell.Value

                Dim tempRng As Range
                Set tempRng = GatherRanges(currCell.Value, Intersect(ws2.Range("A:A"), ws2.UsedRange))

                If Not tempRng Is Nothing Then

                    If Not unionRng Is Nothing Then
                        Set unionRng = Union(unionRng, tempRng)
                    Else
                        Set unionRng = tempRng
                    End If

                End If

            End If

        Next currCell

    End With

    If Not unionRng Is Nothing Then unionRng.EntireRow.Copy ws3.Range("A" & IIf(GetLastRow2(ws3, 1) = 1, 1, GetLastRow2(ws3, 1)))

End Sub

Public Function GatherRanges(ByVal findString As String, ByVal searchRng As Range) As Range

    Dim foundCell As Range
    Dim gatheredRange As Range

    With searchRng

        Set foundCell = searchRng.Find(findString)
        Set gatheredRange = foundCell

        Dim currMatch As Long

        For currMatch = 1 To WorksheetFunction.CountIf(.Cells, findString)

            Set foundCell = .Find(What:=findString, After:=foundCell, _
                                  LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, _
                                  SearchDirection:=xlNext, MatchCase:=False)

            If Not gatheredRange Is Nothing Then
                Set gatheredRange = Union(gatheredRange, foundCell)
            Else
                Set gatheredRange = foundCell
            End If

        Next currMatch

    End With

    Set GatherRanges = gatheredRange

End Function

Public Function GetLastRow2(ByVal ws As Worksheet, Optional ByVal columnNumber As Long = 1) As Long

    With ws

        GetLastRow2 = .Cells(.Rows.Count, columnNumber).End(xlUp).Row

    End With

End Function

Answer 2

Another approach

1. Copy all rows from Sheet1 to Output
2. Sort Output by custom list order ( Sheet2 )
3. Remove all rows in Output not in list (beginning in the last row)

So …

Option Explicit

Public Sub CopyListedRowsAndSortByListOrder()
    Dim wsSrc As Worksheet
    Set wsSrc = Worksheets("Sheet1")

    Dim lRowSrc As Long
    lRowSrc = wsSrc.Cells(wsSrc.Rows.Count, "A").End(xlUp).Row

    Dim wsList As Worksheet
    Set wsList = Worksheets("Sheet2")

    Dim lRowList As Long
    lRowList = wsList.Cells(wsList.Rows.Count, "A").End(xlUp).Row

    Dim wsDest As Worksheet
    Set wsDest = Worksheets("Output")

    'Copy all rows
    wsSrc.Range("A1:C" & lRowSrc).Copy wsDest.Range("A1")

    Dim lRowDest As Long
    lRowDest = wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Row

    'sort Output column B by list in Sheet2
    With wsDest.Sort
        .SortFields.Add Key:=wsDest.Range("B2:B" & lRowDest), _
        SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:= _
        Join(WorksheetFunction.Transpose(wsList.Range("A2:A" & lRowList).Value), ","), DataOption:=xlSortNormal
        .SetRange Range("A1:C" & lRowDest)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

    'remove all rows not in list (backwards)
    Dim i As Long
    For i = lRowDest To 2 Step -1
        If Not IsError(Application.Match(wsDest.Cells(i, "B"), wsList.Range("A2:A" & lRowList))) Then Exit For
    Next i

    wsDest.Range(i + 1 & ":" & lRowDest).Delete xlShiftUp
End Sub

Answer 3

you could try this

Sub Test()
    Dim filts As Variant
    With Worksheets("Sheet2")
        filts = Application.Transpose(.Range("A2", .Cells(.Rows.Count, 1).End(xlUp)).Value)
    End With

    With Worksheets("Sheet1").Range("A1").CurrentRegion
        .AutoFilter Field:=2, Criteria1:=filts, Operator:=xlFilterValues
        If Application.WorksheetFunction.Subtotal(103, .Columns(1)) > 1 Then .Resize(.Rows.Count - 1, .Columns.Count).Offset(1, 0).SpecialCells(xlCellTypeVisible).Copy Worksheets("Output").Range("A1")
        .Parent.AutoFilterMode = False
    End With
End Sub