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