Dim dictFolders As New Scripting.Dictionary
Dim dictFiles As New Scripting.Dictionary
Dim dictFileLike As New Scripting.Dictionary
Dim dictFolderLike As New Scripting.Dictionary
' ******************************************************************************************************
' This is the main procedure that
' ******************************************************************************************************
Private Sub subVBAAddANewColumnInMultipleWorkbooks()
Dim varFolderKey As Variant
Dim varFileKey As Variant
Dim strPath As String
Dim fso As Object
Dim objFolder As Object
ActiveWorkbook.Save
dictFolders.RemoveAll
dictFolderLike.RemoveAll
dictFiles.RemoveAll
dictFileLike.RemoveAll
Set fso = CreateObject("Scripting.FileSystemObject")
' Set the root path.
strPath = "C:\Private\Microsoft Office Documents\Excel\Mr Excel\VBA - Add a new column in multiple workbooks\Files"
' Check to see if the root poath exits.
If Dir(strPath, vbDirectory) = "" Then
MsgBox "Folder does not exist", vbInformation, "Warning!"
Exit Sub
End If
' Include the trailing slash.
If Right(strPath, 1) <> "\" Then
strPath = strPath & "\"
End If
Set objFolder = fso.GetFolder(strPath)
' Specify folder specification.
' For an example. If you only wanted to include folders with the word 'backup' in the name
' you could specify it like this:
' dictFolderLike.Add Key:="*backup*", Item:=dictFolderLike.Count + 1
dictFolderLike.Add Key:="*", Item:=dictFolderLike.Count + 1
' If no folder specs are added to the dictionary then add one to include all folders.
If dictFolderLike.Count = 0 Then
dictFolderLike.Add Key:="*", Item:=dictFolderLike.Count + 1
End If
' Call the subPopulateFoldersDictionary which calls itself calls itself recursivly.
' It is this procedure that populates the folders distionary.
Call subPopulateFoldersDictionary(objFolder)
Set objFolder = Nothing
Set fso = Nothing
' Add file specs to the dictFileLike dictionary.
dictFileLike.Add Key:="*.xls", Item:=dictFileLike.Count + 1
dictFileLike.Add Key:="*.xlsx", Item:=dictFileLike.Count + 1
dictFileLike.Add Key:="*.xlsm", Item:=dictFileLike.Count + 1
' If no file specs are added to the dictionary add one to include all files.
If dictFileLike.Count = 0 Then
dictFileLike.Add Key:="*", Item:=dictFileLike.Count + 1
End If
' Loop throuigh each folder in the didtionary and call prpocedure to
' populate the files dictionary.
For Each varFolderKey In dictFolders.Keys
Call subPopulateFileNamesDictionary(varFolderKey)
Next varFolderKey
Call subPopulateFileNamesDictionary(strPath)
For Each varFileKey In dictFiles.Keys
Call subOpenWorkbookAndInsertColumn(varFileKey)
Next varFileKey
MsgBox "All files have been amended.", vbInformation, "Confirmation"
Application.ScreenUpdating = True
End Sub
' ******************************************************************************************************
' Populates the dictFolders dictionary with a list of folders and sub-folders.
' The list may contain folders that do not contain any files that meet the file criteria.
' Only folders that adhere to the folder spec will be included.
' ******************************************************************************************************
Public Sub subPopulateFoldersDictionary(ByVal objFolder As Object)
Dim SubFolder As Object
Dim subfld As Object
Dim strFolder As String
Dim blnInclude As Boolean
Dim varFolderLike As Variant
' Loop throigh all sub-folders'
For Each SubFolder In objFolder.SubFolders
strFolder = SubFolder.Path
If Right(strFolder, 1) <> "\" Then
strFolder = strFolder & "\"
End If
' Loop through the dictionary of folder specifications.
' Folder only has to meet one of the criteria.
For Each varFolderLike In dictFolderLike.Keys
If strFolder Like varFolderLike Then
dictFolders.Add Key:=strFolder, Item:=dictFolders.Count + 1
blnInclude = True
Exit For
End If
Next varFolderLike
Next SubFolder
' Call this procedure for each sub-folder.
If (dictFolderLike.Count = 0) Or (dictFolderLike.Count > 0 And blnInclude) Then
For Each subfld In objFolder.SubFolders
subPopulateFoldersDictionary subfld
Next subfld
End If
End Sub
' ******************************************************************************************************
' Populates the dictFiles dictionary with a list of files contained within the folders
' in the dictFolders dictionary.
' The file must conform to tha file spec provided.
' ******************************************************************************************************
Public Sub subPopulateFileNamesDictionary(ByVal strFolder As String)
Dim MyFSO As FileSystemObject
Dim MyFile As File
Dim MyFolder As Folder
Dim varFileLike As Variant
Set MyFSO = New Scripting.FileSystemObject
Set MyFolder = MyFSO.GetFolder(strFolder)
For Each MyFile In MyFolder.Files
For Each varFileLike In dictFileLike.Keys
If MyFile Like varFileLike Then
dictFiles.Add Key:=strFolder & MyFile.Name, Item:=dictFiles.Count + 1
End If
Next varFileLike
Next MyFile
End Sub
' ******************************************************************************************************
' Opens each workbook in turn and makes the nececcasry amendments.
' ******************************************************************************************************
Public Sub subOpenWorkbookAndInsertColumn(ByVal strWorkbook As String)
Dim i As Integer
Dim Ws As Worksheet
Dim Wb As Workbook
Dim rngCell As Range
Dim rngColumn As Range
' Open Workbook.
Application.Workbooks.Open strWorkbook
Set Wb = ActiveWorkbook
' Check to see if worksheet exists.
If fncDoesWorksheetExist(Wb, "Daily Report") Then
Set Ws = Wb.Worksheets("Daily Report")
' Unprotect worksheet.
Ws.Unprotect "Password@1"
' Create new column.
Ws.Range("G1").EntireColumn.Insert
Set rngCell = Ws.Range("G1")
With rngCell
.Value = "Local / UC"
.EntireColumn.AutoFit
End With
' Copy formatting from previous header cell.
rngCell.Offset(0, -1).Copy
rngCell.Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
' Create validation drop down list.
Set rngColumn = Ws.Range("A1").CurrentRegion.Columns(1)
Set rngColumn = rngColumn.Resize(rngColumn.Rows.Count - 1.1).Offset(1, rngCell.Column - 1)
rngColumn.Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Formula1:="Local,Up Country"
' Protect worksheet.
Ws.Protect "Password@1"
End If
' Close workbook.
Wb.Close SaveChanges:=True
End Sub
' ******************************************************************************************************
' Returns TRUE if the worksheet whose name is provided exists.
' Returns FALSe if it does not exist.
' ******************************************************************************************************
Public Function fncDoesWorksheetExist(Wb As Workbook, strWorksheet As String) As Boolean
Dim Ws As Worksheet
For Each Ws In Wb.Worksheets
If Ws.Name = strWorksheet Then
fncDoesWorksheetExist = True
Exit For
End If
Next Ws
End Function
