0

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
braX
  • 11,506
  • 5
  • 20
  • 33
  • Instead of using VBA why not just use the Filter function to get what you want? ```=FILTER('Flight Printout'!F4:I203,'Flight Printout'!F4:F203= "Championship")``` in D1 would accomplish this. You could also apply the formula then copy paste the values through vba if you wanted that. – Basbadger May 22 '22 at 18:04
  • I just tried your suggestion and it worked perfectly! I like this much better that the vba route. Thanks! – Charles Langston May 25 '22 at 16:37

1 Answers1

0

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
ouroboros1
  • 9,113
  • 3
  • 7
  • 26
  • This works GREAT! Thank you so much. One thing though: in the post I mentioned that I need to copy and paste Columns A to I , not just the "Championship" word. Any thoughts? – Charles Langston May 22 '22 at 19:58
  • I've edited the code. Now it copies the values from columns A:I at the appropriate row into columns D:L. Comments preceded by triple apostrophes show the changes. – ouroboros1 May 22 '22 at 22:51