Option Explicit
'Boolean variable used to check if book has been updated
Dim mbChecked As Boolean
Sub UpdateSomeProjectWorkbooks()
' Custom DocumentProperty Name
Const cDocPropName As String = "ProjectName"
' Custom DocumentProperty Value (text)
Const cDocPropVal As String = "Data"
Dim lUbk As Long
Dim szFolderPath As String
Dim objFolder As Object
Dim szbkName As String
Dim wbk As Workbook
Dim i As Long
' 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)
If Not objFolder Is Nothing Then
On Error Goto ErrExit 'In case of invalid selection: (Desktop)
If Len(objFolder.items.Item.Path) > 3 Then
szFolderPath = objFolder.items.Item.Path & Application.PathSeparator
Else
szFolderPath = objFolder.items.Item.Path
End If
On Error Goto 0
Else
Exit Sub
End If
' ===========================================================================
' If we picked a folder that contains this workbook, we cannot run:
' The code will stop if it attempts to open this workbook
If szFolderPath <> ThisWorkbook.Path & "\" Then
' Find only Excel related files
' ===========================================================================
With Application.FileSearch
.NewSearch
.LookIn = szFolderPath
.SearchSubFolders = False 'Change to TRUE to search all sub-folders
.Filename = "*.xls"
.MatchTextExactly = True
.FileType = msoFileTypeExcelWorkbooks
' ===========================================================================
' Start opening all the workbooks found, looking for our custom project
' property that identifies the workbook as ours.
' Those workbooks will get updated, others will be skipped
' ===========================================================================
With Application
.ScreenUpdating = False
.EnableEvents = False
If Val(.Version) >= 9 Then 'ShowWindowsInTaskbar is for versions 2000+
.ShowWindowsInTaskbar = False
End If
End With
' Open all excel files in the folder, searching for ones that
' contain our custom document property
If .Execute() > 0 Then
lUbk = 0
For i = 1 To .FoundFiles.Count
Set wbk = Application.Workbooks.Open(.FoundFiles(i))
' =========================================================
' Visual status as to what book is opened:
Application.StatusBar = "Currently Checking: " & wbk.Name
' =========================================================
' Check if our custom document property is contained in the opened workbook
' and error is produced if it's not there
On Error Resume Next
If wbk.CustomDocumentProperties(cDocPropName).Value <> cDocPropVal Then
Err.Clear
' if it doesn't, close this book, we don't need it
wbk.Close False
Else
mbChecked = False
' ===========================================================
' if it does, call our update code:
Call ExampleUpdateCode
If mbChecked Then
' Update the counter if we updated a file
lUbk = lUbk + 1
' Store the workbook names we update in a variable
szbkName = szbkName & vbNewLine & wbk.Name
End If
' Then save and close
With wbk
.Save
.Close
End With
' ===========================================================
End If
Next i
Else
' if no files our found:
MsgBox "There were no files found.", 16
Exit Sub
End If
End With
' Explicitly clear memory
Set wbk = Nothing
Else
' if we tried to run with the master workbook in the same folder
MsgBox "This master workbook cannot be in the same folder as the one being searched", 64
Exit Sub
End If
ErrExit:
With Application
.ScreenUpdating = True
.EnableEvents = True
.StatusBar = Empty
If Val(.Version) >= 9 Then 'ShowWindowsInTaskbar is for versions 2000+
.ShowWindowsInTaskbar = True
End If
End With
' Did we update anything or not?
' Message depends on outcome:
If lUbk > 0 Then
MsgBox "Updated " & lUbk & " project workbooks" & vbNewLine & szbkName, 64
Else
MsgBox "No workbooks were updated", 64
End If
End Sub
Private Sub ExampleUpdateCode()
' Example update code: Just copies the 2005 data sheet to the project workbook
On Error Resume Next
With ActiveWorkbook
.Sheets("2005").Select
End With
If Err.Number <> 0 Then
ThisWorkbook.Sheets("2005").Copy After:=ActiveWorkbook.Sheets(Worksheets.Count)
mbChecked = True
Else
Exit Sub
mbChecked = False
End If
End Sub
|