FindNext doesnt work?

[Whistler]

Hi, i need some help with a code below, in database there are 3 entreys which should be found bat after runnnig the code is returning only first one.

Sub Go_Click()
Dim ws As Worksheet
Dim ws2 As Worksheet
Set ws = Worksheets("DataBase")
Set ws2 = Worksheets("Review")
Dim What As String
Dim Where As Range
Set Where = ws.Range("B:B")
Dim Found As Range
Dim iRow As Long
Dim firstAddress As String
'find first empty row
iRow = ws2.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Row
What = ws2.Range("C4")
With Where
Set Found = .Find(What:=What, After:=Range("B2"), LookAt:=xlPart, MatchCase:=False)
 If Not Found Is Nothing Then
    firstAddress = Found.Address
        Do
        Found.Copy
        ws2.Cells(iRow, 2).PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        Set Found = .FindNext(Found)
        Loop While Not Found Is Nothing And Found.Address <> firstAddress
 End If
End With
End Sub

Thanks for your help

 

[Whistler]

I have manage to resolve it, code below if anyone interested:

Sub Go_Click()
Dim ws, ws2 As Worksheet
Dim Where, Found, Found2, Clear As Range
Dim What, firstAddress As String
Dim iRow As Long
Dim Respond
Dim numRows, numColums
Set ws = Worksheets("DataBase")
Set ws2 = Worksheets("Review")
Set Where = ws.Range("B:B")

What = ws2.Range("C4")
Set Clear = ws2.Range("B6:T30000")
Clear.Clear
With Where
Set Found = .Find(What:=What, After:=Range("B2"), LookAt:=xlWhole, MatchCase:=False)
   
 If Not Found Is Nothing Then
  Found.Copy
    ws2.Cells(4, 10).PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    firstAddress = Found.Address
        Do
        iRow = ws2.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Row
        numRows = Found.Rows.Count
        numColumns = Found.Columns.Count
        Set Found2 = Union(Found.Offset(0, -1), Found.Offset(0, 1).Resize(, 11))
        Found2.Copy
        ws2.Cells(iRow, 2).PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        Set Found = .FindNext(Found)
        Loop While Not Found Is Nothing And Found.Address <> firstAddress
 Else
 
 Respond = MsgBox("No records found", vbOKOnly)
 End If
  
End With
End Sub

Thanks for your help

 

[mikerickson]

Adapting the code from post #5

Do
    ws2.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Resize(1,11).Value = Found.Resize(1,11).Value
    Set Found = .FindNext(Found)
Loop While Not Found Is Nothing And Found.Address <> firstAddress