循环遍历过滤的单元格列表以检查值是不是出现在另一列中，然后复制/粘贴

Posted 2023-03-27

【中文标题】循环遍历过滤的单元格列表以检查值是不是出现在另一列中，然后复制/粘贴

【英文标题】：Loop through filtered list of cells to check if value appears in another column then copy/paste循环遍历过滤的单元格列表以检查值是否出现在另一列中，然后复制/粘贴

【发布时间】：2022-01-23 22:54:57

【问题描述】：

在我的宏方面需要一些帮助。我需要的是遍历 Sheet2 中的 filterable ID 列表，并将它们与工作表 1 的第 16 列中包含的 ID 匹配。然后将 Sheet1 中的整个匹配行复制到 Sheet3 .

Sheet2 通常是这样的（按状态等进行过滤）：

ID	Summary	Created On	Status
1234567	Text	Date	Done
2345678	Text	Date	In Progress

和 Sheet1（*注意 ID -> ID2 匹配）：

ID	Summary	Created On	Status	ID2
#######	Text	Date	Done	1234567, #######, #######
#######	Text	Date	In Progress	#######, 2345678

我在这里使用了这个线程 (Code needed to loop through column range, check if value exists and then copy cells) 用于在不需要过滤的同一个工作簿中进行配对的过程，它似乎工作得很好。但是，我在这种情况下的代码没有正确配对行数，也没有与正确的 ID 配对。我认为混合过滤的配对过程可能有问题？

到目前为止我的代码：

Public Sub PairingBackTEST()

Dim WS As Worksheet
Set WS = Sheets("Sheet1") 

    'Clears Sheet 3
    Sheets("Sheet3").Activate
    Sheets("Sheet3").Cells.Clear

    ' Get the number of used rows for each sheet
    Dim RESULTBlocked As Integer, Blockers As Integer
    RESULTBlocked = WS.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count 
    Debug.Print RESULTBlocked
    
    Blockers = Worksheets(1).Cells(1048576, 1).End(xlUp).Row
    Debug.Print Blockers
    
    RESULTBlockers = Worksheets(4).Cells(1048576, 1).End(xlUp).Row
    
    'Set date/time format for Created On and Due Date columns
    Sheets("Sheet3").Activate
    Sheets("Sheet3").Columns("H:H").Select
    Selection.NumberFormat = "[$-en-US]m/d/yy h:mm AM/PM;@"
    Sheets("Sheet3").Columns("I:I").Select
    Selection.NumberFormat

    'Pairing
    With Worksheets(1) 
        'Loop through Sheet2
        For i = 1 To Blockers
            'Loop through Sheet1
            For j = 1 To RESULTBlocked
                If InStr(1, .Cells(i, 16), WS.Cells(j, 1), vbBinaryCompare) > 0 Then
           
                ' If a match is found:
                    RESULTBlockers = RESULTBlockers + 1
                    For k = 1 To 17 'How ever many columns there are
                    Sheets("Sheet3").Cells(RESULTBlockers, k) = .Cells(i, k)
                    Next
                    Exit For
                Else
                End If
            Next j
        Next i
    End With

    'Prepare headers on RESULT Blocked
    Sheets("Sheet1").Rows(1).Copy
    Sheets("Sheet3").Range("A1").PasteSpecial
    

【问题讨论】：

您可以检查单元格的行是否可见。 （If InStr(1, .Cells(i, 16), WS.Cells(j, 1), vbBinaryCompare) > 0 and row(j) visible = true then。旁注，一般来说你想在你的代码中avoid using Select

ID 的长度总是相同的，一个 id 永远不能是另一个 id 的子字符串？被过滤器隐藏的行会发生什么 - 它们应该从匹配过程中排除？

@TimWilliams ID 始终是 7 个数字，& 在字符串中用逗号分隔。是的，这就是目标，那些被过滤器隐藏的应该被排除在匹配之外。最终目标是我想要一张来自工作表 1 的匹配 ID 表作为报告。

ID 包含在 Sheet 1 的第 4 列中？图片显示状态？ InStr(1, .Cells(i, 16), WS.Cells(j, 1) 正在使用第 16 列那是什么？

@CDP1802 抱歉，这有点不清楚，在视觉示例中我只使用了第 4 列，但实际上它是 16。有很多列。

【参考方案1】：

我可能会尝试这样的方法：

Public Sub PairingBackTEST()
    
    Dim wb As Workbook
    Dim wsList As Worksheet, wsCheck As Worksheet, wsResults As Worksheet
    Dim lrList As Long, lrCheck As Long, c As Range, cDest As Range, id, m
    
    'use workbook/worksheet variables for clarity, and to avoid repetition...
    Set wb = ThisWorkbook
    Set wsList = wb.Worksheets("Sheet2")
    Set wsCheck = wb.Worksheets("Sheet1")
    Set wsResults = wb.Worksheets("Sheet3")

    'no need for activate/select here
    With wsResults
        .Cells.Clear
        .Columns("H:H").NumberFormat = "[$-en-US]m/d/yy h:mm AM/PM;@"
        '.Columns("I:I").NumberFormat = ??? this is missing in your posted code
        wsCheck.Rows(1).Copy .Range("A1") 'copy headers
    End With

    Set cDest = wsResults.Range("A2") 'first destination row on result sheet
    For Each c In wsList.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells
        id = c.Value
        'you can use match in place of looping as long as there's only one row to find
        m = Application.Match("*" & id & "*", wsCheck.Columns(16), 0)
        If Not IsError(m) Then
            If m > 1 Then 'avoid matching on header...
                cDest.Resize(1, 17).Value = wsCheck.Cells(m, 1).Resize(1, 17).Value
                Set cDest = cDest.Offset(1, 0) 'next row on results sheet
            End If
        End If
    Next c
End Sub

【讨论】：

哦，这行得通！太感谢了！我会记住使用匹配——超级有用