Macro to Edit Contents of in Table in Word Header

[jdpw13]

Hi all,

I'm trying to develop a macro that will loop through a folder of word docs, open each one, update the cells of a table in the header according to values I have stored in excel, save and close. The hope is that this will speed up the time consuming process of manually updating 100+ docs one by one when the headers need to be changed to reflect the next project phase.

I'm getting a couple different errors on the "Update Header" line, stating the remote server machine does not exist and that the requested member of the collection does not exist (seems to be alternating between those two ). Another thing I'm unsure of is how to have the macro work on both .doc and .docx files - perhaps an asterisk on that line?

I have very little VBA experience and any help would be greatly appreciated on how to get this up and running! Happy to provide any additional info it it helps. Here is what I've cobbled together from other forum posts so far:

Sub UpdateSpecHeaders()
Dim oWordApp As Object
Dim oWordDoc As Object
Dim sFolder As String, strFilePattern As String
Dim strFileName As String, sFileName As String
'> Folder containing files to update
sFolder = Range("A20").Value
'> Identify file extension to search for
strFilePattern = "*.doc"
'> Establish a Word application object
On Error Resume Next
Set oWordApp = GetObject(, "Word.Application")
If Err.Number <> 0 Then
Set oWordApp = CreateObject("Word.Application")
End If
Err.Clear
On Error GoTo 0
oWordApp.Visible = True
Application.ScreenUpdating = False
'> Loop through the folder to get the word files
strFileName = Dir$(sFolder & strFilePattern)
Do Until strFileName = ""
sFileName = sFolder & strFileName
'> Open the word doc
Set oWordDoc = oWordApp.Documents.Open(sFileName)
'> Update Header
With oWordDoc
section(1).headers(wdHeaderFooterFirstPage).Range.tables (1)
.Cells(6).Text = Range("B3").Value
End With
'> Save and close the file
oWordDoc.SaveAs Filename:=oWordDoc.Name
oWordDoc.Close SaveChanges:=False
'> Find next file
strFileName = Dir$()
Loop
'> Quit and clean up
Application.ScreenUpdating = True
oWordApp.Quit
Set oWordDoc = Nothing
Set oWordApp = Nothing
End Sub