VBA coding question (Copy and Paste looping code)

[Rjohn1]

Hi,

I am new to this website and have looked around but can not find exactly the code i am looking for. Basically, I am trying to search Column A for various words (hopefully they can be pulled from a existing table in excel) and copy and paste them in Column D of the same sheet. The looping part is important because i would like the code to continue to Copy and Paste until the whole group is done and stop where there is a blank cell in Column C. Please refer to my current code and my screenshot.

This is the current code:

Sub FindBalance()
Dim rngFound As Range
With Worksheets("total termite rev mth").Range("A:A")
Set rngFound = .Find(What:="Service: 160", LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)

rngFound.Offset(3, 3).Value = "Service: 160"
rngFound.Offset(4, 3).Value = "Service: 160"
rngFound.Offset(5, 3).Value = "Service: 160"
rngFound.Offset(6, 3).Value = "Service: 160"
rngFound.Offset(7, 3).Value = "Service: 160"
rngFound.Offset(8, 3).Value = "Service: 160"
rngFound.Offset(9, 3).Value = "Service: 160"

Set rngFound = .Find(What:="Service: 161", LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)

rngFound.Offset(3, 3).Value = "Service: 161"
rngFound.Offset(4, 3).Value = "Service: 161"
rngFound.Offset(5, 3).Value = "Service: 161"
rngFound.Offset(6, 3).Value = "Service: 161"
rngFound.Offset(7, 3).Value = "Service: 161"
rngFound.Offset(8, 3).Value = "Service: 161"

End With
End Sub

 

[Rjohn1]

Here is a screenshot of the spreadsheet. As you can see i am trying to automate this to continue to copy down to D36. Each service has a different number of cells it must copy down. So i thought it would be best that the code copy down until it reaches an empty cell in the corresponding cell in Column C.