Sub ExportToWord()
'Turn some stuff off while the macro is running
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
Dim DaySheet As String, BmDateName As String, BmTimeName As String
Dim BmCourseName As String, BmTeamName As String, Courses As String
Dim BmDate As String, BmTime As String
Dim BmCourse As String, FNine As String, BNine As String
On Error Resume Next
Dim wdApp As Word.Application
Dim WdDoc As Word.Document
Set wdApp = CreateObject("Word.Application")
wdApp.Visible = True
Set WdDoc = wdApp.Documents.Open("C:\Users\Sal\Desktop\coxgroup.html")
On Error GoTo 0
For i = 2 To 7
  Select Case i
    Case i = 2: DaySheet = "Monday"
    Case i = 3: DaySheet = "Tuesday"
    Case i = 4: DaySheet = "Wednesday"
    Case i = 5: DaySheet = "Thursday"
    Case i = 6: DaySheet = "Friday"
    Case i = 7: DaySheet = "Saturday"
  End Select
  ' 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)
  Worksheets(DaySheet).Range(BmTeamName).Copy
  ' paste team data into word doc
  With WdDoc
    'Identify current Bookmark range and insert text
    If .Bookmarks.Exists(BmTeamName) Then
      Set BmkRng = .Bookmarks(BmTeamName).Range
      BmkRng.PasteSpecial Link:=False, DataType:=wdPasteHTML, _
      Placement:=wdInLine, DisplayAsIcon:=False
      BmkRng.End = BmkRng.End + Len(Worksheets(DaySheet).Range(BmTeamName).Value)
      .Bookmarks.Add BmTeamName, BmkRng
    Else
      MsgBox "Bookmark: " & BmTeamName & " not found."
    End If
  End With
  Application.CutCopyMode = False
Next i
WdDoc.Close SaveChanges:=True, OriginalFormat:=1
wdApp.Quit
Set WdDoc = Nothing: Set wdApp = Nothing
'Turn everything back on
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True
Application.StatusBar = False
End Sub