Hi guys,

I have a below code, I am currently using to copy the named range from Excel into Word bookmarks. It works find. The only issue I have is when it copies the data, it changes the format of the table (bookmark) in Word. I would like to retain the original formatting in Word and only wants to copy the data/values.

can anyone assist?

Sub CopyNamedRangeToWordBookmark()

'As this code uses early binding, a reference to 'Microsoft Word nn.n Object Library' is required

Dim wrdApp As Word.Application
Dim wrdMyDoc As Word.Document
Dim rngNamedRangeCheck As Range
'Dim objWordApp As Object
Dim blnNewInstance As Boolean

'Verify the path and document name by try to set the 'wrdMyDoc' variable to them
On Error Resume Next
Set wrdMyDoc = GetObject(Range("B1") & Application.PathSeparator & Range("B2"))
If Err.Number <> 0 Then
MsgBox "As there is no document called """ & Range("B2") & """ in the """ & Range("B1") & """ directory, the process has been terminated." & vbNewLine & "Enter a valid document name and / or directory path and try again.", vbCritical, "Populate Word Bookmarks Editor"
Exit Sub
End If
On Error GoTo 0

Set wrdApp = wrdMyDoc.Application

'Need to the variables visible to select the relevant bookmark
wrdApp.Visible = True
wrdMyDoc.ActiveWindow.Visible = True

'Verify the bookmark exists by trying to go to it
On Error Resume Next
wrdApp.Selection.GoTo What:=wdGoToBookmark, Name:=CStr(Range("B3"))
If Err.Number <> 0 Then
MsgBox "As there is no bookmark called """ & Range("B3") & """ in the """ & Range("B2") & """ document the process has been terminated." & vbNewLine & "Create the bookmark and try again.", vbCritical, "Populate Word Bookmarks Editor"
Set wrdApp = Nothing
Set wrdMyDoc = Nothing
Exit Sub
End If
On Error GoTo 0

'Verify the Excel named range exists
On Error Resume Next
Set rngNamedRangeCheck = Range(CStr(Range("B3")))
On Error GoTo 0
If rngNamedRangeCheck Is Nothing Then
MsgBox "As there is no named range called """ & Range("B3") & """ in this workbook the process has been terminated." & vbNewLine & "Create the named range and try again.", vbCritical, "Populate Word Bookmarks Editor"
Set wrdApp = Nothing
Set wrdMyDoc = Nothing
Exit Sub
End If

'If we get here all is OK to copy the Excel named range to the Word bookmark
With Application
.ScreenUpdating = False
.StatusBar = "Please wait while the bookmark is populated..."
End With

Range(CStr(Range("B3"))).Copy
wrdApp.Selection.PasteAndFormat wdFormatOriginalFormatting


Application.CutCopyMode = False

'Insert a date stamp into cell A8.
Range("A8").Value = Evaluate("T(""Last run date: "" &TEXT(NOW(), ""mmm-dd-yyyy"") & "" "" & LOWER(TEXT(NOW(), ""h:mmAM/PM"")))")

'Remove objects from memory
Set wrdApp = Nothing
Set wrdMyDoc = Nothing
Set rngNamedRangeCheck = Nothing

MsgBox "The named range """ & Range("B3") & """ has now been copied to the same bookmark in the """ & Range("B2") & """ word document.", vbInformation, "Populate Word Bookmarks Editor"

With Application
.StatusBar = ""
.ScreenUpdating = True
End With

End Sub