Need some help with my macro. What I need is to loop through a filterable list of IDs in Sheet2 and match them to where the ID is contained in Column 16 on Sheet 1. Then copy over the whole matched row in Sheet1 over to a Sheet3.

Here's what Sheet2 looks like, generally (filtering by things like Status, etc.):

And Sheet1 (*note the ID -> ID2 match):

I used this thread here (Code needed to loop through column range, check if value exists and then copy cells) for a process of pairing in the same workbook that does not need to be filtered, and it seems to work just fine. However, my code in this instance is not pairing the amount of rows correctly nor is it pairing with the correct IDs either. I think something may be off with the pairing process with filtering in the mix?

My code so far:

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
    

CodePudding user response：

I'd maybe try an approach like this:

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