Forum Discussion
Excel macro to import to a Fillable Form in Word
I am attempting to transfer variables from the Excel name manager to bookmarks in Word. I successfully developed a macro for this task, but I am dissatisfied with its behavior as it deletes the bookmark after importing. In my attempts to prevent this deletion, the code I implemented ended up corrupting the file. Provided below is the problematic code segment responsible for the file corruption:
Sub ImportValuesToWord()
Dim wdApp As Object
Dim wdDoc As Object
Dim templatePath As String
Dim bookmarkName As String
Dim cellValue As Variant
Dim nm As Name ' Declare nm as a variable of type Name
' Prompt the user to select the Word document to import values into
With Application.FileDialog(3) ' 3 represents msoFileDialogFilePicker
.Title = "Select the Word document to import values into"
.Filters.Clear
.Filters.Add "Word Documents", "*.docx; *.docm"
If .Show = -1 Then
templatePath = .SelectedItems(1)
Else
Exit Sub ' User canceled the document selection
End If
End With
' Open Word and the selected document
On Error Resume Next
Set wdApp = GetObject(, "Word.Application") ' Attempt to get an existing instance of Word
On Error GoTo 0
If wdApp Is Nothing Then
Set wdApp = CreateObject("Word.Application") ' If no existing instance found, create a new one
End If
' Unprotect the Word document
Set wdDoc = wdApp.Documents.Open(templatePath, ReadOnly:=False)
' Create a temporary unprotected copy of the document
Dim tempPath As String
tempPath = Environ$("temp") & "\" & Format(Now, "yyyyMMddhhmmss") & ".docx" ' Temporarily save the copy in the user's temp folder
wdDoc.SaveAs2 Filename:=tempPath, FileFormat:=12, ReadOnlyRecommended:=False ' Use the value 12 for wdFormatXMLDocument
' Open the temporary copy
Dim wdTempDoc As Object
Set wdTempDoc = wdApp.Documents.Open(tempPath)
' Loop through all defined names in the workbook
For Each nm In ThisWorkbook.Names
bookmarkName = nm.Name
' Check if the bookmark exists in the Word document
If wdTempDoc.Bookmarks.Exists(bookmarkName) Then
' Retrieve the cell value from Excel based on the named range
cellValue = nm.RefersToRange.Value
' Clear the existing content within the bookmark range
Dim bookmarkRange As Object
Set bookmarkRange = wdTempDoc.Bookmarks(bookmarkName).Range
bookmarkRange.Sections(1).ProtectedForForms = False ' Unprotect the section
' Delete the range and insert a new empty range at the same location
bookmarkRange.Copy
wdDoc.Bookmarks(bookmarkName).Range.PasteSpecial
Application.CutCopyMode = False
wdTempDoc.Range(bookmarkRange.Start, bookmarkRange.End).Delete
' Set the new content
wdTempDoc.Bookmarks.Add bookmarkName, wdTempDoc.Range(bookmarkRange.Start, bookmarkRange.Start)
wdTempDoc.Bookmarks(bookmarkName).Range.Text = CStr(cellValue)
bookmarkRange.Sections(1).ProtectedForForms = True ' Protect the section
End If
Next nm
' Save and close the temporary copy
wdTempDoc.SaveAs2 tempPath, FileFormat:=12
wdTempDoc.Close
' Replace the original protected document with the modified copy
Kill templatePath ' Delete the original protected document
Name tempPath As templatePath ' Rename the temporary copy as the original document
' Quit Word application
wdApp.Quit
' Release object references
Set wdTempDoc = Nothing
Set wdDoc = Nothing
Set wdApp = Nothing
End Sub
I figured it out, so if anyone else needs this code in the future, hopefully they can find this. This will insert text from Excel into a fillable form on Word without deleting the fillable blocks. I attached excel and word documents for users to sample and pasted the macro below:
Option Explicit
Sub ImportValuesToWord()
Dim wdApp As Object
Dim wdDoc As Object
Dim templatePath As String
Dim bookmarkName As String
Dim cellValue As Variant
Dim nm As Name ' Declare nm as a variable of type Name
' Prompt the user to select the Word document to import values into
With Application.FileDialog(3) ' 3 represents msoFileDialogFilePicker
.Title = "Select the Word document to import values into"
.Filters.Clear
.Filters.Add "Word Documents", "*.docx; *.docm"
If .Show = -1 Then
templatePath = .SelectedItems(1)
Else
Exit Sub ' User canceled the document selection
End If
End With
' Open Word and the selected document
On Error Resume Next
Set wdApp = GetObject(, "Word.Application") ' Attempt to get an existing instance of Word
On Error GoTo 0
If wdApp Is Nothing Then
Set wdApp = CreateObject("Word.Application") ' If no existing instance found, create a new one
End If
' Open the original protected document
Set wdDoc = wdApp.Documents.Open(templatePath, ReadOnly:=False)
' Unprotect the Word document
wdDoc.Unprotect Password:=""
' Loop through all defined names in the workbook
For Each nm In ThisWorkbook.Names
bookmarkName = nm.Name
' Check if the bookmark exists in the Word document
If wdDoc.Bookmarks.Exists(bookmarkName) Then
' Retrieve the cell value from Excel based on the named range
cellValue = nm.RefersToRange.Value
' Insert the cell value into the Word document
InsertText wdDoc, bookmarkName, CStr(cellValue), False
End If
Next nm
' Protect the Word document again
wdDoc.Protect Type:=wdAllowOnlyFormFields, NoReset:=True
' Save and close the Word document
wdDoc.SaveAs2 templatePath ' Save the document without creating copies
wdDoc.Close
' Quit Word application
wdApp.Quit
' Release object references
Set wdDoc = Nothing
Set wdApp = Nothing
End Sub
Sub InsertText(doc As Object, ByVal bookmarkName As String, ByVal bookmarkText As String, showMsg As Boolean)
On Error GoTo locerr
Dim rng As Object
Dim fld As ObjectOn Error Resume Next
Set rng = doc.Bookmarks(bookmarkName).RangeIf rng Is Nothing Then
If showMsg And Len(Trim(bookmarkText)) > 0 And bookmarkName <> "author" Then
MsgBox "The bookmark named:" _
& vbNewLine & vbNewLine & bookmarkName & vbNewLine & vbNewLine & _
"Is absent from the current document.", vbOKOnly, "Error message"
End If
Else
On Error GoTo locerr
If Len(bookmarkText) = 0 Then
bookmarkText = bookmarkText & " "
End If' If there is a FormField at the bookmark, update its Result property
If rng.FormFields.Count > 0 Then
For Each fld In rng.FormFields
fld.Result = bookmarkText
Next fld
Else
' If no FormField, insert the text normally and reapply the bookmark
rng.Text = bookmarkText
doc.Bookmarks.Add bookmarkName, rng
End If
End IfTidyUp:
Exit Sub
locerr:
If MsgBox(Err.Description & ", " & Err.Number, vbAbortRetryIgnore) = vbRetry Then
Resume
Else
Resume TidyUp
End If
End Sub
5 Replies
I figured it out, so if anyone else needs this code in the future, hopefully they can find this. This will insert text from Excel into a fillable form on Word without deleting the fillable blocks. I attached excel and word documents for users to sample and pasted the macro below:
Option Explicit
Sub ImportValuesToWord()
Dim wdApp As Object
Dim wdDoc As Object
Dim templatePath As String
Dim bookmarkName As String
Dim cellValue As Variant
Dim nm As Name ' Declare nm as a variable of type Name
' Prompt the user to select the Word document to import values into
With Application.FileDialog(3) ' 3 represents msoFileDialogFilePicker
.Title = "Select the Word document to import values into"
.Filters.Clear
.Filters.Add "Word Documents", "*.docx; *.docm"
If .Show = -1 Then
templatePath = .SelectedItems(1)
Else
Exit Sub ' User canceled the document selection
End If
End With
' Open Word and the selected document
On Error Resume Next
Set wdApp = GetObject(, "Word.Application") ' Attempt to get an existing instance of Word
On Error GoTo 0
If wdApp Is Nothing Then
Set wdApp = CreateObject("Word.Application") ' If no existing instance found, create a new one
End If
' Open the original protected document
Set wdDoc = wdApp.Documents.Open(templatePath, ReadOnly:=False)
' Unprotect the Word document
wdDoc.Unprotect Password:=""
' Loop through all defined names in the workbook
For Each nm In ThisWorkbook.Names
bookmarkName = nm.Name
' Check if the bookmark exists in the Word document
If wdDoc.Bookmarks.Exists(bookmarkName) Then
' Retrieve the cell value from Excel based on the named range
cellValue = nm.RefersToRange.Value
' Insert the cell value into the Word document
InsertText wdDoc, bookmarkName, CStr(cellValue), False
End If
Next nm
' Protect the Word document again
wdDoc.Protect Type:=wdAllowOnlyFormFields, NoReset:=True
' Save and close the Word document
wdDoc.SaveAs2 templatePath ' Save the document without creating copies
wdDoc.Close
' Quit Word application
wdApp.Quit
' Release object references
Set wdDoc = Nothing
Set wdApp = Nothing
End Sub
Sub InsertText(doc As Object, ByVal bookmarkName As String, ByVal bookmarkText As String, showMsg As Boolean)
On Error GoTo locerr
Dim rng As Object
Dim fld As ObjectOn Error Resume Next
Set rng = doc.Bookmarks(bookmarkName).RangeIf rng Is Nothing Then
If showMsg And Len(Trim(bookmarkText)) > 0 And bookmarkName <> "author" Then
MsgBox "The bookmark named:" _
& vbNewLine & vbNewLine & bookmarkName & vbNewLine & vbNewLine & _
"Is absent from the current document.", vbOKOnly, "Error message"
End If
Else
On Error GoTo locerr
If Len(bookmarkText) = 0 Then
bookmarkText = bookmarkText & " "
End If' If there is a FormField at the bookmark, update its Result property
If rng.FormFields.Count > 0 Then
For Each fld In rng.FormFields
fld.Result = bookmarkText
Next fld
Else
' If no FormField, insert the text normally and reapply the bookmark
rng.Text = bookmarkText
doc.Bookmarks.Add bookmarkName, rng
End If
End IfTidyUp:
Exit Sub
locerr:
If MsgBox(Err.Description & ", " & Err.Number, vbAbortRetryIgnore) = vbRetry Then
Resume
Else
Resume TidyUp
End If
End SubDexter_G Perhaps this gets you started?
Sub InsertText(doc As Document, ByVal bookmarkName As String, bookmarkText As String, showMsg As Boolean) On Error GoTo locerr Dim rng As Range Dim crlfChars As Long 'Number of line feeds (each causes an extra character) On Error Resume Next Set rng = doc.Bookmarks(bookmarkName).Range bookmarkText = bookmarkText & " " If rng Is Nothing Then If showMsg And Len(Trim(bookmarkText)) > 0 And bookmarkName <> "author" Then MsgBox "the bookmark named:" _ & vbNewLine & vbNewLine & bookmarkName & vbNewLine & vbNewLine & _ "Is absent from the current document.", vbOKOnly, sAppName & ", Error message" End If Else On Error GoTo locerr If Len(bookmarkText) = 0 Then bookmarkText = bookmarkText & " " End If crlfChars = (Len(bookmarkText) - Len(Replace(bookmarkText, vbCrLf, ""))) / 2 With rng .Delete Unit:=wdCharacter, Count:=1 .InsertAfter bookmarkText .SetRange Start:=rng.Start, End:=rng.Start + Len(bookmarkText) - crlfChars End With doc.Bookmarks.Add Range:=rng, Name:=bookmarkName If Right(bookmarkText, 1) = " " Then bookmarkText = Left(bookmarkText, Len(bookmarkText) - 1) End If End If TidyUp: Exit Sub locerr: If MsgBox(Err.Description & ", " & Err.Number, vbAbortRetryIgnore) = vbRetry Then Resume Else Resume TidyUp End If End SubJKPieterse sorry for the lat response. I put together a general example spreadsheet and word document as per the attached. I am getting this error when trying to export the values: "The range cannot be deleted., 6028". Do you have any idea what might be causing this?
Dexter_G I'm afraid I'm offline for the time being worth no access to a pc
