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

Posted 2023-03-27

技术标签:

【中文标题】从另一个工作表的列中的工作表列中搜索每个值，如果找到，则将整行粘贴到输出中【英文标题】：Search a each value from a column of sheet in another sheet's column and if find then paste entire row in output 【发布时间】：2018-09-16 06:19:32 【问题描述】：

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

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

【问题讨论】：

到目前为止你尝试了什么？请edit问题并添加您的代码。 Stack Overflow 不是免费的代码编写服务，因此如果您什么都不做，任何人都不太可能完成所有工作。阅读How to Ask 可能有助于改善您的问题（您甚至还没有问过）。感谢 Peh.. 已添加好吧，首先你不需要.select (How to avoid using Select in Excel VBA)。你能解释一下你的代码出了什么问题吗？有什么错误吗？与您的预期有何不同？ 【参考方案1】：

另一种方法

Sheet1

Output

Sheet2

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

【讨论】：

聪明的想法【参考方案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

【讨论】：

【参考方案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

【讨论】：

以上是关于从另一个工作表的列中的工作表列中搜索每个值，如果找到，则将整行粘贴到输出中的主要内容，如果未能解决你的问题，请参考以下文章

使用python查找Excel的列中是否存在值

用于检查工作表列值的 Google 脚本

在多表列中具有多个术语的简单 PHP 过滤器

返回表列中的最后一个值

如何使用熊猫从另一个数据框 B 的列中删除包含特定数量值的数据框 A 中的行？

根据条件从另一个数据框列中获取值