Tony,
It was probably hanging because you were never exiting your Do loops - due to re-finding the same cells over and over. The following bit of code uses the FindNext method and checks to see if we've re-found the first cell. These two criteria should be sufficient to quit the loops satisfactorily:
Code:
Sub OralSuspensionFinder()
Dim wksSearch As Worksheet
Dim wksOut As Worksheet
Dim intOutRow As Integer
Dim rngFound As Range
Dim strWhat As String
Dim strFirstAddress As String
' Turn off screen updating to increase performance
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set wksSearch = ThisWorkbook.Sheets("Sheet2")
Set wksOut = ThisWorkbook.Sheets("Sheet3")
intOutRow = 2
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Find the word oral
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
strWhat = "oral"
' Add a heading
wksOut.Cells(intOutRow, 1).Value = strWhat
wksOut.Cells(intOutRow, 1).Font.Bold = True
intOutRow = intOutRow + 1
Set rngFound = wksSearch.UsedRange.Find(strWhat)
' If we've found something then proceed
If Not rngFound Is Nothing Then
' Record the first found address
strFirstAddress = rngFound.Address
' Loop until we find no more or get back to the first found instance
Do
' Copy across the values of the row
wksOut.Cells(intOutRow, 1).EntireRow.Value = rngFound.EntireRow.Value
' Increment the ourput row counter
intOutRow = intOutRow + 1
' Find the next instance
Set rngFound = wksSearch.UsedRange.FindNext(rngFound)
Loop Until rngFound Is Nothing Or rngFound.Address = strFirstAddress
End If
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Find the word suspension
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
strWhat = "suspension"
' Add a heading
wksOut.Cells(intOutRow, 1).Value = strWhat
wksOut.Cells(intOutRow, 1).Font.Bold = True
intOutRow = intOutRow + 1
Set rngFound = wksSearch.UsedRange.Find(strWhat)
' If we've found something then proceed
If Not rngFound Is Nothing Then
' Record the first found address
strFirstAddress = rngFound.Address
' Loop until we find no more or get back to the first found instance
Do
' Copy across the values of the row
wksOut.Cells(intOutRow, 1).EntireRow.Value = rngFound.EntireRow.Value
' Increment the ourput row counter
intOutRow = intOutRow + 1
' Find the next instance
Set rngFound = wksSearch.UsedRange.FindNext(rngFound)
Loop Until rngFound Is Nothing Or rngFound.Address = strFirstAddress
End If
'Turn screen updating back on
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub