回圈過濾單元格串列以檢查值是否出現在另一列中，然后復制/粘貼

需要一些有關我的宏的幫助。我需要的是回圈遍歷Sheet2 中可過濾的 ID 串列，并將它們與第 1 列第 16 列中包含的 ID 匹配。然后將 Sheet1 中的整個匹配行復制到 Sheet3。

這是 Sheet2 通常的樣子（按狀態等過濾）：

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

我在這里使用了這個執行緒（代碼需要回圈遍歷列范圍，檢查值是否存在，然后復制單元格）用于在不需要過濾的同一作業簿中進行配對的程序，它似乎作業得很好。但是，我在這個實體中的代碼沒有正確配對行數，也沒有與正確的 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
    

uj5u.com熱心網友回復：

我可能會嘗試這樣的方法：

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

標籤：擅长 vba

上一篇：字串的搜索范圍，更改相鄰單元格的值

下一篇：如果它與另一個范圍相交，則停止觸發事件SelectionChange（已使用Intersect）？