从另一个工作表的列中的工作表列中搜索每个值，如果找到，则将整行粘贴到输出中

Question

我是新手，所以请帮助我。我有一个工作簿，其中包含以下三张纸-

Sheet1- 有 3 个 cloumns- A、B、C Sheet2-有一列-A **输出

如果 Sheet1- Column B 的单元格中的值与 Sheet2 Column A 的任何单元格中的值匹配，则复制整行并粘贴到下一个可用的空白行（从输出表的 A) 列开始。

工作表 2 的 B 列可以有重复的单元格，所有匹配的单元格都应该转到输出工作表的下一个可用行。

**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

我在下面尝试过。不知道有多好-

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

下面也试过了-

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

另一种方法

1. 将所有行从Sheet1 复制到Output
2. 按自定义列表顺序对Output 进行排序 (Sheet2)
3. 删除Output 中不在列表中的所有行（从最后一行开始）

所以……

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 2

类似的东西（假设您是从第一张纸上复制的。不清楚）。

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

如果 sheet2 中的所有内容都匹配复制，则：

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 3

你可以试试这个

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