VBA Find All in Sheet1, then Copy-Paste in Sheet1

[teppuus]

Hello,

I am trying to write a macro for Excel 2003 that will allow me to search for two words in Sheet1, copy all the data below those words, and then paste that data in Sheet2. That part I can get to work. My problem is that I have multiple instances of the words I am searching for (which are Force and Grade). In Sheet1, there are usually 5 instances of Force and Grade each, although the real number is unknown. I can't seem to loop through though so that the macro will search for all instances. It just finds the first instance of each word and copy and pastes that data over and over again. Can someone please help with the proper loop here? Thank you!

Sub Copy_Paste_Bondpull()
'
'Sub Sample1()
    Dim strSearch1 As String   'searches for force
    Dim strSearch2 As String   'searches for grade

    strSearch1 = "Force"
    strSearch2 = "Grade"

    'COPY AND PASTE ALL FORCE VALUES TO FROM SHEET1 TO SHEET2

    Do While i < 5 ' This 5 is just to prevent an infinite loop

        Sheets("Sheet1").Select
        Cells.Find(What:=strSearch1, After:=ActiveCell, LookIn:=xlValues, LookAt:= _
            xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
            , SearchFormat:=False).Activate
        ActiveCell.Offset(1, 0).Activate   'select cell below the word "Force"
        Range(ActiveCell, ActiveCell.End(xlDown)).Select    'select all cells after "Force" to first empty cell
        Selection.Copy
        Sheets("Sheet2").Select
        Cells(Selection.Row, Columns.Count).End(xlToLeft).Offset(0, 1).Select  'paste to next column
        ActiveSheet.Paste


    'COPY AND PASTE ALL GRADE VALUES FROM SHEET1 TO SHEET2
        Sheets("Sheet1").Select
        Cells.Find(What:=strSearch2, After:=ActiveCell, LookIn:=xlValues, LookAt:= _
            xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
            , SearchFormat:=False).Activate
        ActiveCell.Offset(1, 0).Activate  'select cell below the word "Grade"
        Range(ActiveCell, ActiveCell.End(xlDown)).Select   'select all cells after "Grade" to first empty cell
        Selection.Copy
        Sheets("Sheet2").Select
        Cells(Selection.Row, Columns.Count).End(xlToLeft).Offset(0, 1).Select  'paste to next column
        ActiveSheet.Paste

    i = i + 1
    Loop

End Sub

[PerplexedB]

I think using findnext might solve your problem. check out this : http://msdn.microsoft.com/en-us/library/office/ff839746.aspx

Careful, findnext recycles, so it's important to test exactly as explained.