VBA - Add a new column in multiple workbooks

[sanket_sk]

Hi All,

I am stuck on some unique issue and need your help.
I have 40+ protected excel workbooks in different folders, all these folders are located in the Root folder called “CSE”.

I am looking for VBA who will do the following

1. Loop through each subfolder of “CSE”
2. Open Excel Workbook available in Folder and go to sheet “Daily Report”
3. Unprotect sheet “Daily Report” with Password “Password@1”
4. Add new column at G column
5. Name the newly added G Column as “Local / UC”
6. Apply Data validation in newly added column G range “G2:G1901” – Values will Be – “Local”, “Up Country”
7. Protect “Daily Report” with Password “Password@1”
8. Save & Close the workbook.

Root Folder Path
C:\Users\Daily report Sheets \CSE
40 files/ folders are available in the root folder.

Could you please help me develop VBA code for this?

Thanks & Regards,
Sanket

 

[HighAndWilder]

Can I assume that column G is a column at the end of the columns that already exist or does a column have to be inserted?

Thanks

 

[sanket_sk]

C

Can I assume that column G is a column at the end of the columns that already exist or does a column have to be inserted?

Thanks

Can I assume that column G is a column at the end of the columns that already exist or does a column have to be inserted?

Thanks

Hi There,

Column G needs to be inserted with the header name "Local / UC".

Sanket

 

[HighAndWilder]

Do you use column H or is column G to be the last column?

 

[HighAndWilder]

Give this a go.

Copy this into a code module.

Make reference to the Microsoft Scripting Runtime library by going into Tools-references in the VBA Editor.

I have made it flexible enough for your to select the sub-folders and files by specifying a folder and file specification.

You only need to make amendments to the subVBAAddANewColumnInMultipleWorkbooks procedure.

I did not know what file extensions your workbooks have so I have included .xls, .xlsx an .xlsm.
dictFileLike.Add Key:="*.xls", Item:=dictFileLike.Count + 1

Delete the lines you don't need.

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