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

 

[RoryA]

How do you know? Your code will overwrite the same destination cell each time.

 

[mikerickson]

You might try this.

Do
    ws2.Cells(iRow, 2).Value = Found.Value
    Set Found = .FindNext(Found)
Loop While Not Found Is Nothing And Found.Address <> firstAddress

You might want to consider that iRow doesn't change in that loop.
As written and altered, the loop repeatedly writes values to the same cell.

I just realized, it might write the same what value to that cell every time.

 

[Whistler]

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
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
        iRow = ws2.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Row
        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

Sorted

Thanks mikerickson

 

[mikerickson]

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

 

[Whistler]

Thanks very much for help I didnt realie that I'm overwriting that cell.

I have another porblem, at the moment my cde is copying only one cell, what if I would like to copy few cells from the founded row?

Could anyone put me on the right direction?

Thanks

 

[mikerickson]

The .Resize property might be useful, also .Offset, it depends on what you mean by "few cells from the found cell."

 

[Whistler]

I mean exactly 11 cells from founded cell.

 

[mikerickson]

if AA20 is the found cell, what 11 cells do you want?

 

[Whistler]

If AA20 been found then I would like to copy AA20:AK20

I'am trying to use resize method but I have problem with selecting that found cell, code below:

Set ws = Worksheets("DataBase")
Set ws2 = Worksheets("Review")
Dim What As String
Dim Where As Range
Set Where = ws.Range("B:B")
Dim Found, Found2 As Range
Dim iRow As Long
Dim firstAddress As String
Dim Respond
Dim numRows, numColums
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
        iRow = ws2.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Row
        numRows = Found.Rows.Count
        numColumns = Found.Columns.Count
        Found.Select
        Found2 = Selection.Resize(numRows + 11, numColumns)
        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