Creating Mailing list ~ stuck and needs tweaking

[RenDanExcel]

Hello everybody, I'm hoping there is someone who can help me.
What I am trying to do is create a macro that will once activated finds the cell with a specified text (in this case "Platinum Premier") then goes down the column from there checking for cells that are filled, copy the data (text in this case) and open a premade word document, go to a specific part of that document, paste the data, print the document and loop until the cell is reached to signal the end (in this case "Platinum")
So far I've been cobbling together a macro, but it has been sometime since I did anything this complex and could use a helpful hand.
I have this currently

Sub PlatinumPremier()


Dim objWord As Object
Dim rngName As Object
Set objWord = CreateObject("Word.Application")
objWord.Visible = False




Cells.Find(What:="Platinum Premier").Activate
Selection.Offset(1, 0).Select
ActiveCell.Activate
Selection.Copy


If IsEmpty(ActiveCell.Value) Then
Selection.Offset(1, 0).Select
Else
ActiveCell.Activate
Selection.Copy
'document location'
objWord.Documents.Open "L:\Platinum Premier\PlatinumPremier.doc"
.Selection.MoveDown Unit:=wdLine, Count:=3
.Selection.MoveRight Unit:=wdCharacter, Count:=5
.Selection.PasteAndFormat (wdFormatPlainText)
objWord.PrintOut
objWord.Close
objWord.Quit


End If
ActiveCell.Value = "Platinum"


' PlatinumPremier Macro
'


'
End Sub

Any guidance would be much appreciated I'm in a bit of a tizzy over what to do