Change MS Word Doc Properties via MS Excel VBA Macro

[OilEconomist]

Hello all and thanks in advance.

I have a written a MS Excel VBA Macro to change MS Word Document Properties. Why won't any of the other properties besides the "Title" change?

Also, how what code needs to be modified/added so it only opens MS Word once, and then updates each document, and then closes it at the end. If I am running another instance of MS Word, I don't want it or any files open in that instance closed.

The following is sample sheet of what items I have used as an example:

MS Excel VBA to Open MS Word.xlsm
	C	D	E	F	G	H
7	Directory of Existing Files:	C:\Files\
8	File Names	File Status	Title	Company	Subject	Author
9	Test Doc 1.docx	Closed	Test Doc 1	XYZ Phantom Company	Important Doc 1	Me
10	Test Doc 2.docx	Closed	Test Doc 2	XYZ Phantom Company	Important Doc 2	Me 2
11	Test Doc 3.docx	Closed	Test Doc 3	XYZ Phantom Company	Important Doc 3	Me 3
Sheet1

Cells with Data Validation
Cell	Allow	Criteria
E8:H8	List	=Document_Properties

Option Explicit

Sub Files_Change_Doc_Properties_Test()

 '_______________________________________________________________________________________________________
 'Turn off alerts, screen updates, and automatic calculation
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    Application.Calculation = xlManual

            
            
 '_______________________________________________________________________________________________________
 'Dimensioning
  
    'Dim Longs
     Dim i As Long, j As Long
     Dim LastRowNames As Long
     Dim LastColDocProp
     
    'Dim Ranges

     
     
    'Dim Strings
     Dim ShtNm As String
     Dim FileNm As String
     Dim FirstName As String
     Dim LastName As String
     Dim FullName As String
     Dim FolderPath As String
     Dim aTitle As String
     Dim FolderPath_N_FileName
     Dim DocProp As String
     Dim DocPropValue As String

    
    
    'Dim Objects
     Dim wApp As Object
    

    'Dim Timer Variables
     Dim Benchmark As Double
     
     
    'Dim Variants

     
    'Dim Word Documents
     Dim wDoc As Word.Document

 
 
 '_______________________________________________________________________________________________________
 'Code - Timer Benchmark
    Benchmark = Timer
 
 
 '_______________________________________________________________________________________________________
 'Code - Set sheet names
  
    ShtNm = "Sheet1"
     
     
     
 '_______________________________________________________________________________________________________
 'Code - Get names
     
    FolderPath = Cells(7, 4)
    
    'Function LastRowColF(ByVal SheetName As String, ByVal ColNum As Long) As Long
     LastRowNames = LastRowColF(ShtNm, 3)
     
    'Function LastColRowF(ByVal SheetName As String, ByVal RowNum As Long) As Long
     LastColDocProp = LastColRowF(ShtNm, 8)
    
    Set wApp = CreateObject("Word.Application")
    Set wDoc = wApp.Documents.Add(Template:="Normal")
    
    For i = 9 To LastRowNames
        FileNm = Cells(i, 3)
        FirstName = Extract_String_Before_F(FileNm, ".")
        LastName = Extract_String_After_F(FileNm, ".")
    
        FullName = FirstName & " " & LastName
        
        FolderPath_N_FileName = FolderPath & FileNm
        
        aTitle = FullName
        
        Set wDoc = wApp.Documents.Open(FileName:=FolderPath_N_FileName, ReadOnly:=False, AddToRecentfiles:=False)
        wApp.Visible = True
        
        With wDoc
            For j = 5 To LastColDocProp
                DocProp = Cells(8, j)
                DocPropValue = Cells(i, j)
                'MsgBox DocProp & ": " & DocPropValue
                .BuiltinDocumentProperties(DocProp).Value = DocPropValue
                .Close SaveChanges:=True
            Next j
        End With
        
    Next i
    
    Set wDoc = Nothing: Set wApp = Nothing


    'Set wApp = Nothing
    'wApp.Visible = True

 '_______________________________________________________________________________________________________
 'Turn on alerts and screen updates, and calculate
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Calculate




 '_______________________________________________________________________________________________________
 'End of the subroutine/macro
 
 
 
End Sub

 

[NdNoviceHlp]

Is this AI? Your missing some subs/functions: LastRowColF & Extract_String_Before_F. I really don't understand what file properties you want to change.... just the file name? To operate Word as you have described, use get object Word application, if unsuccessful then create object Word application. Set a boolean flag if you create the Word application and only quit the Word application IF you created it. HTH. Dave

 

[OilEconomist]

Is this AI? Your missing some subs/functions: LastRowColF & Extract_String_Before_F. I really don't understand what file properties you want to change.... just the file name? To operate Word as you have described, use get object Word application, if unsuccessful then create object Word application. Set a boolean flag if you create the Word application and only quit the Word application IF you created it. HTH. Dave

Apologies. No it is not AI. Yes those are functions which I have inserted here.

I am trying to change the document properties (e.g. Company) that I have shown in the MS Excel image/attachment, but the only that is changing is the Title.

'****************************************************************************************************
'This function finds the last row within a worksheet/tab for a particular column
'
Function LastRowColF(ByVal SheetName As String, ByVal ColNum As Long) As Long
    Dim WkS As Worksheet
        
        Set WkS = ActiveWorkbook.Worksheets(SheetName)
        
        LastRowColF = WkS.Cells(Rows.Count, ColNum).End(xlUp).Row
        
    
End Function


'****************************************************************************************************
'This function finds the last row within a worksheet/tab

Function LastRowF(ByVal SheetName As String) As Long
    Dim WkS As Worksheet
        
        Set WkS = ActiveWorkbook.Worksheets(SheetName)
        
        LastRowF = WkS.Cells.Find(What:="*", After:=WkS.Cells(1), _
        SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        
    
End Function


'****************************************************************************************************
'This function finds the last column within a worksheet/tab for a paricular row

Function LastColRowF(ByVal SheetName As String, ByVal RowNum As Long) As Long
    Dim WkS As Worksheet
        
        Set WkS = ActiveWorkbook.Worksheets(SheetName)
        
        LastColRowF = WkS.Cells(RowNum, Columns.Count).End(xlToLeft).Column
        
    
End Function


'****************************************************************************************************
'This function finds the last column within a worksheet/tab

Function LastColF(SheetName As String) As String

    Set WkS = ActiveWorkbook.Worksheets(SheetName)
    
    LastColF = WkS.Cells.Find(What:="*", After:=WkS.Cells(1, 1), LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False)



End Function

 

[NdNoviceHlp]

Not real sure why company and author properties aren't changing but according to your other post link, file status and subject are not available document properties. Maybe content status and content type?. Here's how to use only one instance of Word using late binding. HTH. Dave

Dim wApp As Object
Dim wDoc As Object, Flag As Boolean

On Error Resume Next
Set wApp = GetObject(, "word.application")
If Err.Number <> 0 Then
Flag = True
On Error GoTo 0
Set wApp = CreateObject("Word.Application")
End If
'open and set wdoc, do stuff and save/close doc
'clean up
Set wDoc = Nothing
If Flag Then
wApp.Quit
Set wApp = Nothing
End If