View Single Post
 
Old 07-13-2011, 11:33 AM
chipnputt chipnputt is offline Windows Vista Office 2007
Novice
 
Join Date: Jul 2011
Posts: 5
chipnputt is on a distinguished road
Default Stop multiple pastes at bookmark

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

Last edited by macropod; 07-14-2011 at 03:33 PM. Reason: Added code tags & formatting
Reply With Quote