VBA-Excel CTRL Find - vba

Question

I am currently trying to find a certain word within an excel spreadsheet, copy the cell on the right and then paste it a further 3 cells to the right and 3 cells down, before dragging this down.
I have compiled the following which does the job.
Cells.Find(What:="N/C:", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate
Selection.Offset(0, 1).Select
Selection.Copy
Selection.Offset(3, 3).Select
ActiveSheet.Paste
Range(Selection, Selection.End(xlDown)).Select
Selection.FillDown
My question is:
How can I extend this code so it searches for all "N/C:" and does the above
Feel free to provide updates to my initial code if it can be improved

Answer 1

Lightly tested:
Sub Tester()
Dim col As Collection, c, sht As Worksheet
Set sht = ActiveSheet
Set col = FindAll(sht.UsedRange, "N/C:")
Debug.Print "Found " & col.Count & " matches"
For Each c In col
c.Copy c.Offset(3, 3)
sht.Range(c.Offset(3, 3), c.Offset(3, 3).End(xlDown)).FillDown
Next c
End Sub
Public Function FindAll(rng As Range, val As String) As Collection
Dim rv As New Collection, f As Range
Dim addr As String
Set f = rng.Find(what:=val, after:=rng.Cells(rng.Cells.Count), _
LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False)
If Not f Is Nothing Then addr = f.Address()
Do Until f Is Nothing
rv.Add f
Set f = rng.FindNext(after:=f)
If f.Address() = addr Then Exit Do
Loop
Set FindAll = rv
End Function

Answer 2

The short answer is that there is no built-in way to return a range with all the find results (i.e. find all) in one go. You have to find the first result (the code you already have) and then use findNext within a while loop, exiting only when the next result until it refers to the same cell as the first result.
There is a good explanation/implementation at http://www.cpearson.com/excel/findall.aspx