Option Explicit 
 
Sub ChangeLotsOfFilesProperties() 
     '   Attributes we will be changing
     '   Author, Title, Comments
    Const szAuthor As String = "vbaexpress.com" 
    Const szTitle As String = "Updated Title" 
    Const szComments As String = "Batch update code" 
     
     
    Dim szFolderPath As String 
    Dim objFolder As Object 
    Dim szbkName As String 
    Dim lUbk As Long 
    Dim i As Long 
    Dim wkb As Workbook 
    Dim fso As Object 
    Dim f As Object 
     
     
     '   Browse for the folder to search for project workbooks
     '   ===========================================================================
    Set objFolder = CreateObject("Shell.Application"). _ 
    BrowseForFolder(0, _ 
    "Select the folder containing workbooks to update", _ 
    0, Empty) 
     
    On Error GoTo ErrExit 
    If Not objFolder Is Nothing Then 
         
        szFolderPath = objFolder.items.Item.Path 
         
    Else 
         
        Exit Sub 
         
    End If 
     '   ===========================================================================
     
    With Application 
        .ScreenUpdating = False 
        .EnableEvents = False 
        If Val(.Version) >= 9 Then 'ShowWindowsInTaskbar is for versions 2000+
            .ShowWindowsInTaskbar = False 
        End If 
    End With 
     
     
    With Application.FileSearch 
        .NewSearch 
        .LookIn = szFolderPath 
        .SearchSubFolders = False 
        .Filename = "*.xls" 
        .MatchTextExactly = True 
        .FileType = msoFileTypeExcelWorkbooks 
        .Execute 
         
         
         '       if we found some files to update
        If .FoundFiles.Count > 0 Then 
             
             
             '       Loop through them, changing document properties
            For i = 1 To .FoundFiles.Count 
                 
                 
                Set wkb = Workbooks.Open(.FoundFiles(i)) 
                 
                 
                 '           Procedure can be lengthy, status bar for updating
                Application.StatusBar = "[" & i & " of " & _ 
                .FoundFiles.Count & "] Changing properties for " & wkb.Name 
                 
                 
                 
                 '           Late binding reference to the FileSystemObject
                Set fso = CreateObject("Scripting.FileSystemObject") 
                Set f = fso.GetFile(ActiveWorkbook.FullName) 
                 
                 
                 '           If the file is Read-Only, don't update it
                If f.Attributes And 1 Then 
                     
                     '               so close it:
                    wkb.Close False 
                     
                Else 
                     
                     '               Otherwise change the specific document properties
                    With wkb 
                         
                         
                         '                   Props we are changing, Author, Title, Comments
                        .BuiltinDocumentProperties("Author") = szAuthor 
                        .BuiltinDocumentProperties("Title") = szTitle 
                        .BuiltinDocumentProperties("Comments") = szComments 
                         
                         
                         '                   Store the workbook names we update in a variable
                         '                   This will be used to deliver our final message
                        szbkName = szbkName & vbNewLine & wkb.Name 
                         
                         
                         '                    Then save and close
                        .Save 
                        .Close 
                         
                         
                    End With 
                     
                End If 
                 
            Next i 
             
        Else 
             
            MsgBox "No files found to update", 64 
             
        End If 
         
    End With 
     
     
ErrExit: 
     '   Explicitly clear memory
    Set wkb = Nothing 
    Set fso = Nothing 
    Set f = Nothing 
    Set objFolder = Nothing 
     
    With Application 
        .ScreenUpdating = True 
        .EnableEvents = True 
        If Val(.Version) >= 9 Then 'ShowWindowsInTaskbar is for versions 2000+
            .ShowWindowsInTaskbar = True 
        End If 
        .StatusBar = Empty 
    End With 
     
    MsgBox "* Properties have been changed for these Files: *" & szbkName, 64 
End Sub