This code creates a copy of a Word document and open that new copy.
When I include code to transfer data it crashes when it goes to open the newly saved copy.
I can run the code to save and open a new copy.
I can run the code to transfer text from a single cell (still troubleshooting moving tables).
When I combine these codes it begins to bug out.
Sub TrialFour()
'pop-up to inform user
MsgBox ("Please Select the CF Word Template")
'saves CF template to where you choose
Dim WordApp As Object, WordDocu As Object, path As String
Dim dlgSaveAs As FileDialog, fileSaveName As Variant
'Allows CF Template to be opened
With Application.FileDialog(msoFileDialogOpen)
.Show
If .SelectedItems.Count = 1 Then
path = .SelectedItems(1)
End If
End With
If path = "" Then
Exit Sub
End If
Set WordApp = CreateObject("Word.Application")
Set WordDocu = WordApp.Documents.Open(path)
WordApp.Visible = False
MsgBox ("Select the location for where the CF Document should be saved and name it for the Site")
' Allows CF Template to be saved under a different file location and name
fileSaveName = Application.GetSaveAsFilename( _
fileFilter:="Word Documents (*.docx), *.docx")
WordApp.ActiveDocument.SaveAs2 Filename:=fileSaveName, _
FileFormat:=wdFormatDocumentDefault
WordApp.ActiveDocument.Close
WordApp.Quit
Set WordApp = Nothing
Set WordDocu = Nothing
MsgBox ("Select the newly saved Site CF Scope")
'open newly saved Document
Dim FileToOpen As Variant
Dim WordDoc As Word.Application
'File path designation
FileToOpen = Application.GetOpenFilename(Title:="Select recently saved CF Scope", fileFilter:="Word Files (*.docx*),*docx*")
If FileToOpen = False Then
Err.Clear
End If
' Create a new Word application
Set oAPP = CreateObject("Word.Application")
' Check if the file exists
If Dir(FileToOpen) <> "" Then
' Make Word visible
oAPP.Visible = True
' Open the document
oAPP.Documents.Open Filename:=FileToOpen
Dim wDoc
'select the open document you want to paste into
Set wDoc = WordApp.ActiveDocument
'copy site name
ThisWorkbook.Worksheets(Sheet1.Name).Range("A6").Copy
'select the word range you want to paste into
wDoc.Bookmarks("Site_Name").Select
'and paste the clipboard contents
WordApp.Selection.PasteAndFormat (wdFormatPlainText)
'copy Building List
ThisWorkbook.Worksheets(Sheet3.Name).ListObjects("Building_List").Range.Copy
wDoc.Bookmarks("Building_List").Select
WordApp.Selection.PasteAndFormat (wdFormatPlainText)
Else
MsgBox "File not found: " & FileToOpen, vbExclamation, "Error"
End If
' Error handling
On Error GoTo ErrorHandler
Exit Sub
ErrorHandler:
MsgBox "An error occurred: " & Err.Description, vbCritical, "Error"
End Sub
The problem occurs because your code is not logical. You save and close the document and quit Word before you have finished working with the document.
I have commented out all of your unnecessary code and replaced it with more logical steps.
Option Explicit
Sub TrialFour()
'pop-up to inform user
MsgBox ("Please Select the CF Word Template")
'saves CF template to where you choose
Dim WordApp As Object, WordDocu As Object, path As String
Dim dlgSaveAs As FileDialog, fileSaveName As Variant
'Allows CF Template to be opened
With Application.FileDialog(msoFileDialogOpen)
.Show
If .SelectedItems.Count = 1 Then
path = .SelectedItems(1)
End If
End With
If path = "" Then
Exit Sub
End If
Set WordApp = CreateObject("Word.Application")
Set WordDocu = WordApp.Documents.Open(path)
WordApp.Visible = True
MsgBox ("Select the location for where the CF Document should be saved and name it for the Site")
' Allows CF Template to be saved under a different file location and name
fileSaveName = Application.GetSaveAsFilename( _
fileFilter:="Word Documents (*.docx), *.docx")
WordApp.ActiveDocument.SaveAs2 Filename:=fileSaveName, _
FileFormat:=wdFormatDocumentDefault
'**** As you haven't filled in the Excel data yet all of this code is pointless
' WordApp.ActiveDocument.Close
' WordApp.Quit
'
' Set WordApp = Nothing
' Set WordDocu = Nothing
'
' MsgBox ("Select the newly saved Site CF Scope")
'
''open newly saved Document
' Dim FileToOpen As Variant
' Dim WordDoc As word.Application
'
' 'File path designation
' FileToOpen = Application.GetOpenFilename(Title:="Select recently saved CF Scope", fileFilter:="Word Files (*.docx*),*docx*")
' If FileToOpen = False Then
' Err.Clear
' End If
'
' ' Create a new Word application
' Set oAPP = CreateObject("Word.Application")
'
' ' Check if the file exists
' If Dir(FileToOpen) <> "" Then
' ' Make Word visible
' oAPP.Visible = True
' ' Open the document
' oAPP.Documents.Open Filename:=FileToOpen
'
'
'
'
'Dim wDoc
'
'
' 'select the open document you want to paste into
' Set wDoc = WordApp.ActiveDocument
'copy site name
ThisWorkbook.Worksheets(Sheet1.Name).Range("A6").Copy
'**** There is no need to select anything
'select the word range you want to paste into
'wDoc.Bookmarks("Site_Name").Select
'and paste the clipboard contents
'WordApp.Selection.PasteAndFormat (wdFormatPlainText)
If WordDocu.Bookmarks.Exists("Site_Name") Then _
WordDocu.Bookmarks("Site_Name").Range.PasteAndFormat wdFormatPlainText
'copy Building List
ThisWorkbook.Worksheets(Sheet3.Name).ListObjects("Building_List").Range.Copy
'**** There is no need to select anything
' wDoc.Bookmarks("Building_List").Select
' WordApp.Selection.PasteAndFormat (wdFormatPlainText)
If WordDocu.Bookmarks.Exists("Building_List") Then _
WordDocu.Bookmarks("Building_List").Range.PasteAndFormat (wdFormatPlainText)
'**** Unless the user is expected to make more changes to the document
'**** this is the point where you should save and close the document and quit Word
' Else
' MsgBox "File not found: " & FileToOpen, vbExclamation, "Error"
' End If
'
' ' Error handling
' On Error GoTo ErrorHandler
'
' Exit Sub
'
'ErrorHandler:
' MsgBox "An error occurred: " & Err.Description, vbCritical, "Error"
End Sub