find, copy, and paste matching values

Question

I have a sorted list and need to search in "Flight Printout" sheet, column F for value "Championship". Copy and Paste ALL matches, including data from columns A:I, to "View POY Pts Recap" sheet, column D. So far, this code finds the first "Championship" entry, copies and pastes it, but then stops. I need it to loop until all matches are copied and pasted.

Sub FindLoop()
    Dim strFirstAddress As String
    Dim rngFindValue As Range
    Dim rngSearch As Range
    Dim rngFind As Range

    Sheets("Flight Printout").Select
  
    Set rngFind = ActiveSheet.Range("F4:F203")
    Set rngSearch = rngFind.Cells(rngFind.Cells.Count)
    Set rngFindValue = rngFind.Find("Championship", rngSearch, xlValues)
    If Not rngFindValue Is Nothing Then
      strFirstAddress = rngFindValue.Address


      Do
        Sheets("Flight Printout").Select

        Set rngFindValue = rngFind.FindNext(rngFindValue)
        rngFindValue.Copy
        Sheets("View POY Pts Recap").Select
        Range("D1").Select
        ActiveSheet.Paste
        ActiveCell.Offset(1).Select

      Loop Until rngFindValue.Address = strFirstAddress

    End If

End Sub

Answer 1

If you walk through your code with F8, you may notice that you 1) never copy/paste the first match, and 2) keep overwriting the value of D1 with all subsequent matches. Also, try to avoid .select, instead make it a habit to declare and set your workbook/worksheets. Finally, use .value = .value instead of copy/paste. See: How to avoid using Select in Excel VBA.

The following rewrite should work, I think:

Sub FindLoop()

Dim strFirstAddress As String
Dim rngFindValue As Range
Dim rngSearch As Range
Dim rngFind As Range

'dim wb and sheets
Dim wb As Workbook
Dim wsFlight As Worksheet, wsView As Worksheet

'set them
Set wb = ActiveWorkbook
Set wsFlight = wb.Sheets("Flight Printout")
Set wsView = wb.Sheets("View POY Pts Recap")

'Set rngFind = ActiveSheet.Range("F4:F203")
Set rngFind = wsFlight.Range("F4:F203")

Set rngSearch = rngFind.Cells(rngFind.Cells.Count)
Set rngFindValue = rngFind.Find("Championship", rngSearch, xlValues)

If Not rngFindValue Is Nothing Then

    'row to start "pasting" values, increment after each find
    Dim new_row As Long
    
    'will get last row in column 4 ("D")
    new_row = wsView.Cells(wsView.Rows.Count, 4).End(xlUp).Row
    
    'if it's the first row and the cell is empty, start at 1, else add 1 to new_row
    If Not (new_row = 1 And wsView.Cells(new_row, 4) = "") Then
    
        new_row = new_row + 1
    
    End If

    strFirstAddress = rngFindValue.Address
    
    '''use for resize below
    colLength = Columns("I").Column

    '''insert values in "D1:L1"
    
    '''resize Range("D1") to match length of wsFlight.Columns("A:I") / define range wsFlight A:I at row found match
    wsView.Cells(new_row, 4).Resize(1, colLength).value = Range(wsFlight.Cells(rngFindValue.Row, "A"), wsFlight.Cells(rngFindValue.Row, "I")).value
    '''wsView.Cells(new_row, 4) = rngFindValue
    
    'Debug.Print rngFindValue.Address()
    
    'increment new_row
    new_row = new_row + 1
    
    'initiate first find next before the do loop starts
    Set rngFindValue = rngFind.FindNext(rngFindValue)
 
    'Do Until ... Loop instead of Do ... Loop Until. Evaluates BEFORE, not AFTER:
    'this way, you will skip the Do ... Loop when there is only 1 match in the range

    Do Until rngFindValue.Address = strFirstAddress
    
    '---delete all this
        'Sheets("Flight Printout").Select
        
        'Set rngFindValue = rngFind.FindNext(rngFindValue)
        'rngFindValue.Copy
        '.Select
        'Range("D1").Select
        'ActiveSheet.Paste
        'ActiveCell.Offset(1).Select
    '---
    
        'insert value in "D2" etc.
        
        '''resize Range("D1") again, etc.
        wsView.Cells(new_row, 4).Resize(1, colLength).value = Range(wsFlight.Cells(rngFindValue.Row, "A"), wsFlight.Cells(rngFindValue.Row, "I")).value
        '''wsView.Cells(new_row, 4) = rngFindValue
        
        'Debug.Print rngFindValue.Address()
        
        'increment new_row
        new_row = new_row + 1
        
        'initiate find next again
        Set rngFindValue = rngFind.FindNext(rngFindValue)
        
    Loop

End If

End Sub