Find Text in a sheet

[fari1]

hi,my below code finds a text fruit in the sheet and then in the next row,or next right or left rows looks for the word apple and then copies the next 500 rows of the row apple including apple row and paste it into the sheet2. this code is not working properly somehow, anyhelp on this would be greatly appreciated.

Sub Findfruit()
Application.ScreenUpdating = False
  
Dim target_fruit As String, fruitrow As Long, qtyrows As Long, targetfruit_row As Long
  
target_fruit = InputBox("What fruit are you looking for?", "Enter Fruit")
' **IF YOU ARE SET ON 500 ROWS TO COPY THEN YOU CAN COMMENT OUT THE NEXT 3 LINES AND THE 5th.
On Error Resume Next
qtyrows = InputBox("How many rows do you want to copy?", "Enter number of Rows")
If qtyrows < 1 Then
qtyrows = 500
End If
  
   
    Cells.Find(What:=target_fruit, After:=Cells(ActiveCell.Row, "a"), LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False).Activate
    targetfruit_row = ActiveCell.Row
    Cells.Find(What:="fruit", After:=Cells(1, 1), LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False).Activate
testagain:
    If ActiveCell.Row <= targetfruit_row Then
        fruitrow = ActiveCell.Row
    Cells.Find(What:="fruit", After:=Cells(ActiveCell.Row, ActiveCell.Column), LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False).Activate
        If ActiveCell.Row < fruitrow Then
        GoTo continue
        Else
    GoTo testagain
    End If
    End If
continue:
    Rows(fruitrow & ":" & fruitrow + qtyrows).Copy
Dim lastsheet2 As Long
lastsheet2 = Sheets("Sheet2").[a65536].End(xlUp).Rows
    Sheets("sheet2").Activate
    Sheets("Sheet2").Cells(lastsheet2 + 1, 1).Select
    ActiveSheet.Paste
Application.ScreenUpdating = True
  
  
  
End Sub

 

[Pediez]

Try this code

[FONT=Courier New]text fruit in the sheet and then in the next row,or next right or left rows looks for the word apple and then copies the next 500 rows of the row apple including apple row and paste it into the sheet2[/FONT]

[/FONT]
[FONT=Courier New]Sub test()
Dim myfound As Range
Set myfound = Cells.Find(What:="Fruit", LookIn:=xlValues, LookAt:=xlPart)
If Not myfound Is Nothing Then
 If myfound.Offset(0, -1).Value = "Apple" Or myfound.Offset(1, 0).Value = "Apple" Or _
 myfound.Offset(0, 1).Value = "Apple" Then
  myfound.Resize(500, 2).Copy Sheet2.Range("A1")
  Else
 End If
Else
MsgBox "Not found"
Exit Sub
End If
End Sub

 

[fari1]

this code is first finding the fruit, if not found thne looks for apple while what i want is to first find the fruit in the sheet and then vba code to see if there's apple word written in the next row of each fruit found, if it is,then copy the next 500 including the apple rows of it and paste it in into sheet3.hope i didn't confuse you

 

[pedie]

Yes 'm kind of confused maybe.....maybe someone can check more for you...

[/FONT]
[FONT=Courier New]Function Find_Range(Find_Item As Variant, _
    Search_Range As Range, _
    Optional LookIn As Variant, _
    Optional LookAt As Variant, _
    Optional MatchCase As Boolean) As Range
     
    Dim c As Range
    If IsMissing(LookIn) Then LookIn = xlValues
    If IsMissing(LookAt) Then LookAt = xlPart
    If IsMissing(MatchCase) Then MatchCase = False
     
    With Search_Range
        Set c = .Find( _
        What:=Find_Item, _
        LookIn:=LookIn, _
        LookAt:=LookAt, _
        SearchOrder:=xlByRows, _
        SearchDirection:=xlNext, _
        MatchCase:=MatchCase, _
        SearchFormat:=False)
        If Not c Is Nothing Then
            Set Find_Range = c
            firstaddress = c.Address
            Do
                Set Find_Range = Union(Find_Range, c)
                Set c = .FindNext(c)
            Loop While Not c Is Nothing And c.Address <> firstaddress
        End If
    End With
End Function
Sub FindAllFruitsandTheApplesArounditandCopy()
Dim c As Range
Dim x As String
Dim fountcoutn As Integer
Dim y As Integer
y = 1
x = InputBox("Please specify below what you want to find...")
If x = "" Then Exit Sub
If IsNull(x) Then Exit Sub[/FONT]
[FONT=Courier New]'On Error GoTo notF
Find_Range(x, Sheets("FindDATA").Range("A1:E20")).Select[/FONT]

[FONT=Courier New]Sheets("FindDATA").Activate
For Each c In Selection
 If c.Offset(0, -1).Value = "Apple" Or c.Offset(1, 0).Value = "Apple" Or _
   c.Offset(0, 1).Value = "Apple" Then
    c.Resize(500).Copy Sheet2.Columns(y)
    y = y + 1
  End If
Next c
Exit Sub
notF:
MsgBox "No " & x & " found"
End Sub