Sub ExportToWord()
Dim wdApp As Word.Application
Dim WdDoc As Word.Document
Dim DaySheet As String, BmDateName As String, BmTimeName As String, _
BmCourseName As String, BmTeamName As String, Courses As String
Dim MondayDate As Date, TuesdayDate As Date, WednesdayDate As Date, _
ThursdayDate As Date, FridayDate As Date, SaturdayDate As Date
Dim Prompt As String, TeamRange As String, BmDate As String, BmTime As String, _
BmCourse As String, FNine As String, _
BNine As String, Title As String, BmkNm As String
Dim myRange As Range, cell As Range, BmTeam As Excel.Range
Dim str
'Turn some stuff off while the macro is running
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
On Error Resume Next
Set wdApp = CreateObject("Word.Application")
If Err.Number <> 0 Then 'Word isn't already running
End If
wdApp.Documents.Open "C:\Users\Sal\Desktop\coxgroup.html"
wdApp.Visible = True
On Error GoTo 0
For i = 2 To 7
  If i = 2 Then
    DaySheet = "Monday"
  End If
  If i = 3 Then
    DaySheet = "Tuesday"
  End If
  If i = 4 Then
    DaySheet = "Wednesday"
  End If
  If i = 5 Then
    DaySheet = "Thursday"
  End If
  If i = 6 Then
    DaySheet = "Friday"
  End If
  If i = 7 Then
    DaySheet = "Saturday"
  End If
  ' define bookmark names
  BmDateName = DaySheet & "Date"
  BmCourseName = DaySheet & "Course"
  BmTimeName = DaySheet & "Time"
  BmTeamName = DaySheet & "Teams"
  Courses = Worksheets(DaySheet).Range("D24")
  FNine = Proper(CutFirstWord(Courses))
  BNine = Proper(CutLastWord(Courses))
  ' define bookmark text
  BmCourse = FNine & " - " & BNine
  BmDate = " " & ThisWorkbook.Worksheets("Sign-Ups").Cells(1, i)
  BmDate = Format(BmDate, "dddd - mmmm d, yyyy")
  If Worksheets(DaySheet).Cells(24, 1) = "Y" Then
    BmTime = Format(Worksheets("Sign-Ups").Cells(3, i), "h:m AM/PM") & " SHOTGUN"
  Else
    BmTime = "TEE TIMES"
  End If
  ' send text data to word doc
  Call WB(BmDateName, BmDate)
  Call WB(BmCourseName, BmCourse)
  Call WB(BmTimeName, BmTime)
  ' define team data
  BmkNm = BmTeamName
  Set BmTeam = Worksheets(DaySheet).Range(BmTeamName)
  Worksheets(DaySheet).Activate
  Worksheets(DaySheet).Range(BmTeamName).Select
  Selection.Copy
  ' paste team data into word doc
  With ActiveDocument
    'Identify current Bookmark range and insert text
    If .Bookmarks.Exists(BmkNm) Then
      .Bookmarks(BmkNm).Range.PasteSpecial Link:=False, DataType:=wdPasteHTML, _
      Placement:=wdInLine, DisplayAsIcon:=False
    End If
  End With
  Application.CutCopyMode = False
Next i
ActiveDocument.Protect Type:=wdAllowOnlyFormFields, NoReset:=True
ActiveDocument.Unprotect
ActiveDocument.SaveAs ("C:\Users\Sal\Desktop\coxgroup.html")
wdApp.Quit
'Turn everything back on
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True
Application.StatusBar = False
End Sub

Sub WB(ByVal BmName As String, ByVal data As String)
If ActiveDocument.Bookmarks.Exists(BmName) Then
  Dim r As Object
  Set r = ActiveDocument.Bookmarks(BmName).Range
  r.Text = data
  ActiveDocument.Bookmarks.Add BmName, r
Else
  Debug.Print "Bookmark not found: " & BmName
End If
End Sub