Hi Paul -
Thank you for the code suggestion but I do not want to enter the data through the message box. The information is readily available and I am trying to automate it with the click of a button. There are four bookmarks to be updated for date, course, time and teams. The first three work perfectly, the four (teams) is the problem child. In order to give you a feel for the programming the following 2 subs are used to transfer the data. As I stated earlier, the first three bookmarks are wordwrapped types and the fourth is embedded an imbedded type. I have tried linking the teams from excel and that works fine. The problem is that the data is not there when the file is copied through FTP to the host website. Then I went to pastespecial which kept the formatting (text coloring, underlining and bold) - perfect. Schedules get changed almost daily if not hourly and when I make the necessary updates and transfer the data is when the problem occurs. I need help with deleting the existing information at the bookmark and then pasting in the text at the bookmark. I have included the two UDF subs I am using, any suggestions would be appreciated.
Code:
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
This sub is used in the above sub for the first 3 bookmarks - works perfectly!!
Code:
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