find text and copy adjacent cell to different sheet - excel

Question

I need help. I need to search my worksheet and find a specific word ("substances"), then copy the value in the cell 2 columns over into a different sheet.
For example, in Sheet1, if "substances" was found in A4, then copy value from C4 and paste into Sheet2 under last filled row. I need to continue doing this for the entire worksheet. "Substances" does not occur sequentially, but always in column A (i.e. the first occurrence may be A4, the ext one might be in A16).
Here's what I have so far:
Dim Cell, cRange As Range
Set cRange = Sheets("Sheet1").Range("A1:A75")
For Each Cell In cRange
FindCounter = 0
If Cell.Value = "Substances" Then
FindCounter = FindCounter + 1
Sheets("Sheet1").Cell.Value(0, 2).Copy
Sheets("Sheet2").Range("A" & Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Row + 1).PasteSpecial xlPasteValues
End If
Next
Application.ScreenUpdating = True

Answer 1

Try this. Find is more efficient than looping (for reasons I have never fully understood).
Sub x()
Dim rFind As Range, s As String
With Sheets("Sheet1").Range("A1:A75")
Set rFind = .Find(What:="Substances", Lookat:=xlWhole, MatchCase:=False, SearchFormat:=False)
If Not rFind Is Nothing Then
s = rFind.Address
Do
Sheets("Sheet2").Range("A" & Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Row + 1).Value = rFind.Offset(, 2).Value
Set rFind = .FindNext(rFind)
Loop While rFind.Address <> s
End If
End With
End Sub

Answer 2

Alternative using for loop:
Sub Copy()
Dim i As Long
Dim lRow1 As Long, lRow2 As Long
Dim ws1 As Worksheet, ws2 As Worksheet
'set worksheets
Set ws1 = Sheets("Sheet1")
Set ws2 = Sheets("Sheet2")
'set last row to search for substances
lRow1 = ws1.Range("A" & ws1.Rows.Count).End(xlUp).Row
'start for loop
For i = 1 To lRow1
If ws1.Range("A" & i).Value = "Substances" Then
'assuming you want to paste into column A on sheet 2
'adjust as you need to
lRow2 = ws2.Range("A" & ws2.Rows.Count).End(xlUp).Row + 1
ws2.Range("A" & lRow2).Value = ws1.Range("A" & i).Offset(0, 2).Value
End If
Next
'clear objects
Set ws1 = Nothing
Set ws2 = Nothing
End Sub