VBA Code Opening Word in Read-Only Mode

[Carin]

I'm attempting to run a macro in excel that copies data from named ranges into a Word Document using bookmarks. When running the below Macro, my Word files opens yet no changes are made. I believe it's because it opens in Read-Only mode. I have gone into options and checked and unchecked boxes to trust the document, etc. Can anyone look at my code to see if you can tell why it is doing this? I'm suspecting the code below in blue font, I found this code online to use a name cell with the file location. I'm not familiar with it.
Thank you!


Option Explicit

Sub MyMacro()

'Early Binding by preselecting Tools References Microsoft Word 16.0 Object Library

Dim WordApp As New Word.Application
Dim doc As Word.Document


Dim CTC_N_Received As Word.Range
Dim CTC_N_Validated As Word.Range
Dim CTC_N_Returned As Word.Range
Dim CTC_N_Awaiting As Word.Range

Dim CTC_P_Received As Word.Range
Dim CTC_P_Validated As Word.Range
Dim CTC_P_Returned As Word.Range
Dim CTC_P_Awaiting As Word.Range

Dim docPath As String

WordApp.Visible = True

Set doc = WordApp.Documents.Open([WordPath].Text, , True)

Set CTC_N_Received = doc.Bookmarks("CTC_N_Received").Range
CTC_N_Awaiting.Text = Range("CTC_N_Received").Value

Set CTC_N_Validated = doc.Bookmarks("CTC_N_Validated").Range
CTC_N_Awaiting.Text = Range("CTC_N_Validated").Value

Set CTC_N_Returned = doc.Bookmarks("CTC_N_Returned").Range
CTC_N_Awaiting.Text = Range("CTC_N_Returned").Value

Set CTC_N_Awaiting = doc.Bookmarks("CTC_N_Awaiting").Range
CTC_N_Awaiting.Text = Range("CTC_N_Awaiting").Value

Set CTC_P_Received = doc.Bookmarks("CTC_P_Received").Range
CTC_N_Awaiting.Text = Range("CTC_P_Received").Value

Set CTC_P_Validated = doc.Bookmarks("CTC_P_Validated").Range
CTC_N_Awaiting.Text = Range("CTC_P_Validated").Value

Set CTC_P_Returned = doc.Bookmarks("CTC_P_Returned").Range
CTC_N_Awaiting.Text = Range("CTC_P_Returned").Value

Set CTC_P_Awaiting = doc.Bookmarks("CTC_P_Awaiting").Range
CTC_N_Awaiting.Text = Range("CTC_P_Awaiting").Value




End Sub

 

[Trebor76]

Hi Carin,

Try this:

Option Explicit
Sub Macro1()

    Dim objWordApp    As Object
    Dim objWordDoc    As Object
    Dim objWordTask   As Object
    Dim blnIsFileOpen As Boolean
    Dim varMyRange    As Variant
    
    Application.ScreenUpdating = False
    
    'Check if Word is already opened
    On Error Resume Next
        Set objWordApp = GetObject(, "Word.Application")
        If Err.Number <> 0 Then
            'If it isn't, open a new instance
            Set objWordApp = CreateObject("Word.Application")
        End If
    On Error GoTo 0
    
    'Check if Word document is open.
    'Note, the full path of the Word document is found from a named range
    'within the Excel workbook called "WordPath".
    For Each objWordTask In objWordApp.Tasks
        If InStr(objWordTask.Name, Dir(ThisWorkbook.Names("WordPath").RefersToRange.Value)) > 0 Then
            Set objWordDoc = objWordApp.Documents(Dir(ThisWorkbook.Names("WordPath").RefersToRange.Value))
            blnIsFileOpen = True
            Exit For
        End If
    Next objWordTask
    'If it isn't, open the Word document
    If blnIsFileOpen = False Then
        Set objWordDoc = objWordApp.Documents.Open(ThisWorkbook.Names("WordPath").RefersToRange.Value)
    End If
    
    'Make Word visible
    objWordApp.Visible = True
    
    'The array consists of the Excel named ranges and Word bookmarks which it is assumed are the same in both
    For Each varMyRange In Array("CTC_N_Received", "CTC_N_Validated", "CTC_N_Returned", "CTC_N_Awaiting", _
                                 "CTC_P_Received", "CTC_P_Validated", "CTC_P_Returned", "CTC_P_Awaiting")
        objWordApp.Selection.Goto What:=-1, Name:=CStr(varMyRange) '-1 = wdGoToBookmark
        ThisWorkbook.Names(CStr(varMyRange)).RefersToRange.Copy
        objWordApp.Selection.PasteAndFormat 16 '16 = wdFormatOriginalFormatting
    Next varMyRange
    
    Application.ScreenUpdating = True

End Sub

Note I use late binding as it makes the code more scalable should other uses use it too.

Regards,

Robert

 

[Carin]

Thank you so much. It still isn't working . I'm getting a VBA 400 error. The Word document opens in edit mode so that's good but the data doesn't transfer over.

 

[Trebor76]

Hi Carin,

Not too sure as I could get it to work

If it's just text you're trying to change try the following, slightly more simple code:

Option Explicit
Sub Macro1()

    Dim objWordApp    As Object
    Dim objWordDoc    As Object
    Dim objWordTask   As Object
    Dim objWordBkm    As Object
    Dim blnIsFileOpen As Boolean
    Dim varMyRange    As Variant
   
    Application.ScreenUpdating = False
   
    'Check if Word is already opened
    On Error Resume Next
        Set objWordApp = GetObject(, "Word.Application")
        If Err.Number <> 0 Then
            'If it isn't, open a new instance
            Set objWordApp = CreateObject("Word.Application")
        End If
    On Error GoTo 0
   
    'Check if Word document is open.
    'Note, the full path of the Word document is found from a named range
    'within the Excel workbook called "WordPath".
    For Each objWordTask In objWordApp.Tasks
        If InStr(objWordTask.Name, Dir(ThisWorkbook.Names("WordPath").RefersToRange.Value)) > 0 Then
            Set objWordDoc = objWordApp.Documents(Dir(ThisWorkbook.Names("WordPath").RefersToRange.Value))
            blnIsFileOpen = True
            Exit For
        End If
    Next objWordTask
    'If it isn't, open the Word document
    If blnIsFileOpen = False Then
        Set objWordDoc = objWordApp.Documents.Open(ThisWorkbook.Names("WordPath").RefersToRange.Value)
    End If
   
    'Make Word visible
    objWordApp.Visible = True
   
    'The array consists of the Excel named ranges and Word bookmarks which it is assumed are the same in both
    For Each varMyRange In Array("CTC_N_Received", "CTC_N_Validated", "CTC_N_Returned", "CTC_N_Awaiting", _
                                 "CTC_P_Received", "CTC_P_Validated", "CTC_P_Returned", "CTC_P_Awaiting")
        Set objWordBkm = objWordDoc.Bookmarks(CStr(varMyRange)).Range
        objWordBkm.Text = ThisWorkbook.Names(CStr(varMyRange)).RefersToRange.Value
    Next varMyRange
   
    Application.ScreenUpdating = True

End Sub

Note if the Word document is read-only the bookmark text should still change but you won't be able to subsequently save the changes so I can't see that as the issue.

You were using early binding so check no references now start with "MISSING". To do this go into the Excel macro and from the Tools menu select References. Deselect (unclick) any references that start with MISSING.

If there's still an issue you may to use a hosting site to post both the Excel and Word documents so I (or someone else) can try and pinpoint what's failing.

Regards,

Robert

 

[Carin]

It still didn't work. I did step into the first macro and in this section:

For Each objWordTask In objWordApp.Tasks
If InStr(objWordTask.Name, Dir(ThisWorkbook.Names("WordPath").RefersToRange.Value)) > 0 Then
Set objWordDoc = objWordApp.Documents(Dir(ThisWorkbook.Names("WordPath").RefersToRange.Value))
blnIsFileOpen = True
Exit For
End If
it looped around a lot (felt like 50 times) then a got a popup that read, "Microsoft Excel is waiting for another Application to complete an OLE Action." I selected Okay then that too circled around for so many times that I just had to restart my computer.

I did try (2nd macro) looking for any reference checked starting with "Missing" but I didn't see any item that started with missing to check or uncheck.

I am unfamiliar with a hosting site if you wouldn't mind explaining. Thanks again and I'm sorry I've taken up so much of your time.

 

[Trebor76]

Hi Carin,

The green section is just looking through each item in your taskbar to determine if the Word document is open or not. I've changed that in the following which uses a custom function to check this so no looping which hopefully will do the job (I'm somewhat at a loss if it doesn't as it's working for me ) :

Option Explicit
Sub Macro1()

    Dim objWordApp As Object
    Dim objWordDoc As Object
    Dim objWordBkm As Object
    Dim varMyRange As Variant
    
    'Check if Word is already opened
    On Error Resume Next
        Set objWordApp = GetObject(, "Word.Application")
        If Err.Number <> 0 Then
            'If it isn't, open a new instance
            Set objWordApp = CreateObject("Word.Application")
        End If
    On Error GoTo 0
    
    Select Case FileStatus(ThisWorkbook.Names("WordPath").RefersToRange.Value)
        Case Is = 0 'File exists but is not open
            Set objWordDoc = objWordApp.Documents.Open(ThisWorkbook.Names("WordPath").RefersToRange.Value)
        Case Is = 70 'File is open
            Set objWordDoc = objWordApp.Documents(Dir(ThisWorkbook.Names("WordPath").RefersToRange.Value))
        Case Is = 53
            MsgBox "Invalid file name"
            Exit Sub
        Case Is = 76
            MsgBox "Invalid path"
            Exit Sub
    End Select
    
    'Make Word visible
    objWordApp.Visible = True
    
    'The array consists of the Excel named ranges and Word bookmarks which it is assumed are the same in both
    For Each varMyRange In Array("CTC_N_Received", "CTC_N_Validated", "CTC_N_Returned", "CTC_N_Awaiting", _
                                 "CTC_P_Received", "CTC_P_Validated", "CTC_P_Returned", "CTC_P_Awaiting")
        Set objWordBkm = objWordDoc.Bookmarks(CStr(varMyRange)).Range
        objWordBkm.Text = ThisWorkbook.Names(CStr(varMyRange)).RefersToRange.Value
    Next varMyRange
    
    Application.ScreenUpdating = True
    
End Sub
'http://www.vbaexpress.com/kb/getarticle.php?kb_id=468
Function FileStatus(strFileName As String) As Long

    Dim lngFileNum As Long
    Dim lngErr     As Long
     
    On Error Resume Next
        lngFileNum = FreeFile()
        Open strFileName For Input Lock Read As #lngFileNum
        Close lngFileNum
        FileStatus = Err
    On Error GoTo 0
     
End Function

You definitely have the full path (directory and filename) of the Word document in an Excel range called "WordPath" right?

Regards,

Robert

 

[Carin]

See address for "WordPath"

Didn't work.
I'm at a loss I can't figure out why this won't work!
The macro does open the Word Document, it just doesn't copy the data from the excel cell into the named range in Word.
This macro was just for a few items, my management team wants about 60 items updated twice week. A Copy/Paste over and over again was just a painful task and was really hoping this would work. I must have a setting set somewhere that's causing the VBA 400 error.
You've been wonderful and I appreciate your time more than you know.

 

[eduzs]

Try in a throw away copy of your files:

objWordDoc.Bookmarks(CStr(varMyRange)).Range = ThisWorkbook.Names(CStr(varMyRange)).RefersToRange.Value

 

[Carin]

Try in a throw away copy of your files:

objWordDoc.Bookmarks(CStr(varMyRange)).Range = ThisWorkbook.Names(CStr(varMyRange)).RefersToRange.Value

I placed at the end of the macro and it didn't do anything different. Perhaps I set up the sheet wrong? I have my bookmarks named the same as the defined cells in excel. I can't understand why the data won't update? Could it be a setting or a version of software?

 

[eduzs]

I did a test here and the macro works well with named ranges / word bookmarks "Bookmark1" and "Bookmark2"!
Perhaps the problem is within the named ranges, some are "PPT Entry" entry, you probably need to use only "Workbook" scope to work.