VBA Looping Through Worksheet to find multiple instances of word - excel

Question

I am trying to write a macro for excel that searches Sheet1 and
finds all instances of the words Force and Grade, then
copies the cells beneath those words (all cells to the first empty row), and pastes to Sheet2.
These words (Force and Grade) can be found in any cell in Worksheet1 and the size of the used area changes every time the file is created.
So far, I can only get it to find the first instance of each word. I have tried many types of loops from examples on this website and others.
I feel like this should be simple, so I am not sure why I can't find the solution. I have tried a For Next Loop that starts with For i To ws.Columns.Count (with "ws" set to Sheet1), but it turns into an infinite loop (although the total column count was only around 15). Any help or nudge in the right direction would be appreciated.
Here is the code that works so far:
my code
'COPY AND PASTE ALL FORCE VALUES TO FROM SHEET1 TO SHEET2
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
numBonds = Range(ActiveCell, ActiveCell.End(xlDown)).Count
Selection.Copy
Sheets("Sheet2").Select
Cells(Selection.Row, Columns.Count).End(xlToLeft).Offset(0, 1).Select 'paste to next column
ActiveSheet.Paste

Answer 1

You should use FindNext to indentify all the matches. Something like this to copy all cells below all instances of Force to column A of Sheet2
Dim StrSearch As String
Dim rng1 As Range
Dim rng2 As Range
StrSearch = "Force"
With Worksheets(1).UsedRange
Set rng1 = .Find(StrSearch, , xlValues, xlPart)
If Not rng1 Is Nothing Then
strAddress = rng1.Address
Set rng2 = rng1
Do
Set rng1 = .FindNext(rng1)
Set rng2 = Union(rng2, rng1)
Loop While Not rng1 Is Nothing And rng1.Address <> strAddress
End If
End With
If Not rng2 Is Nothing Then
For Each rng3 In rng2
Range(rng2.Offset(1, 0), rng3.End(xlDown)).Copy Sheets(2).Cells(Rows.Count, "A").End(xlUp)
Next
End If

Answer 2

With Worksheets(1).UsedRange
'Code to copy and paste Force values
Set rng1 = .Find(strSearch1, LookIn:=xlValues)
SampleCnt = Application.WorksheetFunction.CountIf(Sheets("Sheet1").Range("A1:BJ2000"), "Grade")
Do While i < SampleCnt
rng1.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
numBonds = Range(ActiveCell, ActiveCell.End(xlDown)).Count
Selection.Copy
Sheets("Sheet2").Select
Worksheets("Sheet2").Columns(Cnt).Select
ActiveSheet.Paste
Sheets("Sheet1").Select
Set rng1 = .FindNext(rng1)
Cnt = Cnt + 2
i = i + 1
Loop
'Code to copy and paste Grade values
Cnt = 4
i = 0
Set rng2 = .Find(strSearch2, LookIn:=xlValues)
Do While i < SampleCnt
rng2.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
numBonds = Range(ActiveCell, ActiveCell.End(xlDown)).Count
Selection.Copy
Sheets("Sheet2").Select
Worksheets("Sheet2").Columns(Cnt).Select
ActiveSheet.Paste
Sheets("Sheet1").Select
Set rng2 = .FindNext(rng2)
Cnt = Cnt + 2
i = i + 1
Loop
End With