Sub PopulateWord()
Dim appWD As Word.Application
Set appWD = CreateObject("Word.Application")
With Sheets("By Event Name")
  If Range("B2").Value = "" Then
    Range("A1", Range("A1").End(xlToRight)).Copy
  Else
    Range("A1", Range("A1").End(xlToRight).End(xlDown)).Copy
  End If
End With
With appWD
  .DisplayAlerts = False
  .Documents.Open FileName:="U:\TPCentral_Too\Templates\PD_HO_Announcement\PD_ HO_Announcement2.htm", ConfirmCoversions:=False
  With .ActiveDocument
    .Range.Delete
    .Range.Paste
    .Close SaveChanges:=True
  End With
  .DisplayAlerts = True
  .Quit
End With
End Sub