I have a spreadsheet that I want to open two Word documents, do a bunch of stuff and then add all the contents of one to the end of the other. I've managed to figure out how to do the bunch of stuff, but for the life of me I can't seem to copy the contents of one to end of the other (which I thought would be the easiest part).
My code:
Sub Redate_OUT()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.DisplayStatusBar = True
Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("Settings")
Dim pdf_path As String
Dim word_path As String
Dim Updated_path As String
pdf_path = sh.Range("E4").Value
Updated_path = sh.Range("E5").Value
word_path = "\\filestorage\cie\Operations\Results Team\Enquiries About Results\1.Series Folders\June 2022\4. Letters\OUT\Redater\Temporary Folder (Word)"
Dim fso As New FileSystemObject
Dim fo As Folder
Dim f As File
Dim MonthNo As Long
Dim MonthType As String
Dim Check As Boolean
Set fo = fso.GetFolder(pdf_path)
Dim wa As Object
Dim doc As Object
Dim FinalWording As Object
Set wa = CreateObject("word.application")
wa.Visible = True
Dim file_Count As Integer
Set FinalWording = wa.Documents.Open("\\filestorage\cie\Operations\Results Team\Enquiries About Results\1.Series Folders\June 2022\4. Letters\OUT\Redater\Final Wording.docx")
For Each f In fo.Files
Application.StatusBar = "Converting - " & file_Count 1 & "/" & fo.Files.Count
Set doc = wa.Documents.Open(f.Path)
doc.SaveAs2 (word_path & "\" & Replace(f.Name, ".pdf", ".docx"))
doc.Close False
Set doc = wa.Documents.Open(word_path & "\" & Replace(f.Name, ".pdf", ".docx"))
For MonthNo = 12 To 1 Step -1
MonthType = MonthName(MonthNo)
With doc.Content.Find
.Text = "?? " & MonthType & " 2022"
.Replacement.Text = Format(Date, "dd") & " " & MonthName(Format(Date, "mm")) & " " & Format(Date, "yyyy")
.MatchWildcards = True
.MatchWholeWord = True
.Execute Replace:=wdReplaceAll
If .Found = True Then
Check = True
GoTo Done
End If
End With
Next
Done:
If Check = True Then
With doc.Content.Find
.Text = "If you believe we have not arrived at this outcome properly, * Enquiry About Results Team"
.Replacement.Text = ""
.MatchWildcards = True
.MatchWholeWord = True
.Execute Replace:=wdReplaceAll
End With
FinalWording.Content.WholeStory 'Select whole document
Selection.Copy 'Copy your selection
Documents(doc.Name).Activate 'Activate the other document
Selection.EndKey wdStory 'Move to end of document
Selection.PasteAndFormat wdPasteDefault 'Pastes in the content
doc.ExportAsFixedFormat OutputFileName:=Updated_path & "/" & f.Name, ExportFormat:=wdExportFormatPDF, Range:=2
doc.Close
End If
file_Count = file_Count 1
Next
FinalWording.Close False
wa.Quit
Kill word_path & "\" & "*.docx"
MsgBox "All OUT Letters have been updated", vbInformation
Application.StatusBar = ""
End Sub
My main difficulty is with:
FinalWording.Content.WholeStory 'Select whole document
Selection.Copy 'Copy your selection
Documents(doc.Name).Activate 'Activate the other document
Selection.EndKey wdStory 'Move to end of document
Selection.PasteAndFormat wdPasteDefault 'Pastes in the content
I get an error (Object does not support this property or method) with:
Selection.EndKey wdStory 'Move to end of document
I'm also not convinced that the contents of the FinalWording document is actually being copied, as when I try to paste this manually after that line of code has run, nothing happens.
On a side note, after the PDF is saved as a word document, I've been closing this and opening again to have a variable to use (doc). As I don't need to save the word document, if there's an easier way of doing this without having to close and open it, I would greatly appreciate that.
Many thanks.
CodePudding user response:
You can replace this entire block:
FinalWording.Content.WholeStory 'Select whole document
Selection.Copy 'Copy your selection
Documents(doc.Name).Activate 'Activate the other document
Selection.EndKey wdStory 'Move to end of document
Selection.PasteAndFormat wdPasteDefault 'Pastes in the content
With:
doc.Characters.Last.FormattedText = FinalWording.Content.FormattedText