Insert a ROW of data to multiple - differently named, and located, but same structured workbooks

[ita]

Insert a ROW of data to multiple - differently named, and located, but same structured workbooks
Excel 2007
Windows 7 OS
Environment:<?xml:namespace prefix = o ns = "urn:schemas-microsoft-comfficeffice" /><o></o>
Excel 2007 in a SharePoint environment with full rights and access to all the folders, subfolders, and files.
Workbook called “Masterproject.xlsx” is in a folder for master files used as a template (not really a “template” format just used as an empty example to copy) and is NOT currently linked to any other workbooks, has already been copied (multiple times over 20 to 100) to another folder called “projects” and under several subfolders of various names call “(whatever city name)” (depending on the location of the project) and under various file names called “cityproject.xlsx” (the word city in the file name is really just the various city names) (i.e. chicagoproject.xlsx, or londonproject.xlsx, or mumbaiproject.xlsx, etc.)
All the files may have different names and locations, BUT the internal structure of all the files are the identical. They have the same sheet names, cell locations, etc. However, there is data in some cells that are different from each other and should be different and should not be changed or overwritten. (just moved around after inserting the new row or rows)
Request:<o></o>
After the initial setup, and use of all the copied files (that now has important different data in the cells) I want to add a needed “new” row of information to the structure of all the files.
A cool way to do this would be to only have to add the row to the “Master” and it would make that same exact row data addition in all existing files, somehow updating all the other files. (I am willing to touch each of the existing files once if I need to do so, or whatever)
I am at a loss as to how to do this accurately or effectively without manually doing this each time to each file individually. And the answer may be “Not possible”.
Any assistance is greatly appreciated. Seems like a good puzzle. Any brave takers?

 

[b.downey]

You are absolutly correct. The issue is with the "path". (You previous programming experiencing is paying off)

In the code the "fd.SelectedItems(1)" parameter that is returned from the Dialog box returns the full path name. I use this information to call the "Dir" function. Unfortunally, the Dir function returns the XLSX files that we need, but does not return the path associated with the file. I have modified the code to store the path (from the "fd.SelectedItems(1)" parameter) and then use that information when issuing the Workbooks.Open Method.

The plan going forward would be to recursevly move thru each of the sub folders that branch out from the folder selected via the dialog box. This would allow me to resuse most of the code already developed.

What is the maximum depth of folders that you envision?

Option Explicit
Sub Process()
    Dim wsResults As Worksheet
    Dim WbTrg As Workbook
    Dim ws As Worksheet
    
    Dim fd As FileDialog
    Dim FileName As String
    
    Dim FilePath As String
    Dim BackupFilePath As String
    
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    With fd
        .AllowMultiSelect = False
        .Show
    End With
    
    If fd.SelectedItems.Count <= 0 Then
        Exit Sub
    End If
    Set wsResults = GetResultsWs(ThisWorkbook)
    
    FilePath = fd.SelectedItems(1) & "\"
    BackupFilePath = FilePath & "BackUp"
    If Len(Dir(BackupFilePath, vbDirectory)) = 0 Then
        MkDir BackupFilePath
    End If
    
    FileName = Dir(FilePath & "*project.xlsx")
    Do While Len(FileName) > 0
        FileName = FilePath & FileName
        
        'Open the Target Workbook as Read only
        Workbooks.Open FileName:=FileName, ReadOnly:=False, UpdateLinks:=False
        Set WbTrg = ActiveWorkbook
        WbTrg.SaveCopyAs BackupFilePath & WbTrg.Name
        
        Call WriteResults(wsResults, "Processing File: " & FileName)
        Call ModifyTrgWs(WbTrg.Worksheets(1))
        
        'Close the Target WorkBook
        'WbTrg.Save
        WbTrg.Close SaveChanges:=True
        
        'Get next file in the directory
        FileName = Dir()
    Loop
    
    MsgBox "Complete", vbInformation
End Sub
Function WriteResults(wsResults As Worksheet, s As String)
    Dim RowNo As Long
    RowNo = wsResults.Range("A" & wsResults.Rows.Count).End(xlUp).Row + 1
    
    wsResults.Cells(RowNo, "A") = Now()
    wsResults.Cells(RowNo, "B") = s
End Function
Function GetResultsWs(wb As Workbook) As Worksheet
    Const SheetName As String = "Results"
    Dim ws As Worksheet
    
    For Each ws In wb.Worksheets
        If ws.Name = SheetName Then
            Set GetResultsWs = ws
            Exit Function
        End If
    Next
    
    wb.Sheets.Add After:=Worksheets(Worksheets.Count)
    wb.ActiveSheet.Name = SheetName
End Function
Function ModifyTrgWs(wsTrg As Worksheet)
    Dim wsMst As Worksheet
    
    Dim MstRow As Long
    Dim TrgRow As Long
    
    Set wsMst = ThisWorkbook.Sheets(1)
    
    TrgRow = 1
    For MstRow = 1 To wsMst.Range("A" & wsMst.Rows.Count).End(xlUp).Row
        If wsMst.Cells(MstRow, 1) <> wsTrg.Cells(TrgRow, 1) Then
            wsMst.Rows(MstRow).Copy
            wsTrg.Rows(TrgRow).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        End If
        TrgRow = TrgRow + 1
    Next MstRow
End Function

 

[b.downey]

Here is the recursive version that will go three folder levels deep from the Folder selected in the dialog box

Option Explicit
Dim wsResults As Worksheet
Sub Process()
    Dim fd As FileDialog
    Dim FilePath As String
    
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    With fd
        .AllowMultiSelect = False
        .Show
    End With
    
    If fd.SelectedItems.Count <= 0 Then
        Exit Sub
    End If
    Set wsResults = GetResultsWs(ThisWorkbook)
    
    FilePath = fd.SelectedItems(1) & "\"
    Call ProcessDir(FilePath, 1)
    
    MsgBox "Complete", vbInformation
End Sub
Function ProcessDir(ByVal FilePath As String, ByVal Level As Integer)
    Dim FileName As String
    Dim BackupFilePath As String
    
    Dim DirList() As String
    
    Dim WbTrg As Workbook
    Dim ws As Worksheet
    
    Dim I As Long
    
    If Level > 3 Then
        Exit Function
    End If
    Debug.Print "Level: " & Level, FilePath
    Level = Level + 1
    
    BackupFilePath = FilePath & "BackUp\"
    If Len(Dir(BackupFilePath, vbDirectory)) = 0 Then
        MkDir BackupFilePath
    End If
    
    FileName = Dir(FilePath & "*project.xlsx")
    Do While Len(FileName) > 0
        Call ProcessFile(FilePath & FileName)
        
        'Get next directory entry
        FileName = Dir()
    Loop
    
    'Now recursevly process sub-directories
    Call GetSubDirs(FilePath, DirList)
    For I = 1 To UBound(DirList)
        Call ProcessDir(DirList(I) & "\", Level)
    Next I
End Function
Function ProcessFile(ByVal FileName As String)
    Dim WbTrg As Workbook
    
    'Open the Target Workbook as Read only
    Workbooks.Open FileName:=FileName, ReadOnly:=False, UpdateLinks:=False
    Set WbTrg = ActiveWorkbook
    'WbTrg.SaveCopyAs BackupFilePath & WbTrg.Name
        
    Call WriteResults(wsResults, "Processing File: " & FileName)
    Call ModifyTrgWs(WbTrg.Worksheets(1))
    
    'Close the Target WorkBook
    WbTrg.Close SaveChanges:=True
End Function
Function GetSubDirs(ByVal FilePath As String, DirList() As String)
    Dim FileName As String
    Dim DirCnt As Long
    
    ReDim DirList(0)
    
    FileName = Dir(FilePath, vbDirectory)
    Do While Len(FileName) > 0
        Select Case LCase(FileName)
            Case ".", "..", "backup"
                'Ignore
            Case Else
                If GetAttr(FilePath & FileName) And vbDirectory Then
                    DirCnt = DirCnt + 1
                    ReDim Preserve DirList(DirCnt)
                    DirList(DirCnt) = FilePath & FileName
                End If
        End Select
        FileName = Dir
        DoEvents
    Loop
End Function
Function WriteResults(wsResults As Worksheet, s As String)
    Dim RowNo As Long
    RowNo = wsResults.Range("A" & wsResults.Rows.Count).End(xlUp).Row + 1
    
    wsResults.Cells(RowNo, "A") = Now()
    wsResults.Cells(RowNo, "B") = s
End Function
Function GetResultsWs(wb As Workbook) As Worksheet
    Const SheetName As String = "Results"
    Dim ws As Worksheet
    
    For Each ws In wb.Worksheets
        If ws.Name = SheetName Then
            Set GetResultsWs = ws
            Exit Function
        End If
    Next
    
    wb.Sheets.Add After:=Worksheets(Worksheets.Count)
    wb.ActiveSheet.Name = SheetName
End Function
Function ModifyTrgWs(wsTrg As Worksheet)
    Dim wsMst As Worksheet
    
    Dim MstRow As Long
    Dim TrgRow As Long
    
    Set wsMst = ThisWorkbook.Sheets(1)
    
    TrgRow = 1
    For MstRow = 1 To wsMst.Range("A" & wsMst.Rows.Count).End(xlUp).Row
        If wsMst.Cells(MstRow, 1) <> wsTrg.Cells(TrgRow, 1) Then
            wsMst.Rows(MstRow).Copy
            wsTrg.Rows(TrgRow).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        End If
        TrgRow = TrgRow + 1
    Next MstRow
End Function

 

[ita]

Wow! It works great! Thank you. It goes through the "Projects" folder and sub folders and finds the sheets and makes the additional row(s) as we wanted it too. Amazing!

There is only this folder structure (only 2 levels) after the MAIN folder:

MAIN (folder)
.....Master.XLMX (file)
.....PROJECTS (folder)
.........BERLIN (folder)
.............berlinproject.xlsx (folder)
.........CHICAGO (folder)
.............chicagoproject.xlsx (file)
.........LONDON (folder)
.............londonproject.xlsx (file)
.........ROME (folder)
.............romeproject.xlsx (file)

YOUR PROGRAM ADDED "Backup" (folder) into every folder

MAIN (folder)
.....Master.XLMX (file)
.....PROJECTS (folder)
..........BACKUP (folder)
..........BERLIN (folder)
...............BACKUP (folder)
...............berlinproject.xlsx (folder)
..........CHICAGO (folder)
...............BACKUP (folder)
...............chicagoproject.xlsx (file)
..........LONDON (folder)
...............BACKUP (folder)
...............londonproject.xlsx (file)
..........ROME (folder)
...............BACKUP (folder)
...............romeproject.xlsx (file)

So as you see above we have backup folder in all the folders. This is a nice feature which I didn't ask for and it is really a nice bonus. (There is nothing in them, and the latest program doesn't copy the "target" file before or even after the changes, so they are all empty.)

A thought about the backup, I ran your "code" that you sent just prior to this latest one, it made the backups, however, it did not put them in the backup directory. They stayed in the one directory with the file it backed up. So my thought is a pathing thing again, BUT thinking forward to the lastest code that iterates through 3 levels of directories, the location for all these backup folders would not work, because the "backupfile" would be a "TARGET" too. (and it would create a backup of the backup, and next run a backup of the backup of the backup...etc. (Now I see you have some code to "Ignore" certain things. That may work, once we test out the reason they are not being copied.... but I am thinking, can I just specifiy a single "BACKUP" folder for all the "TARGET" files to dump to? I am thinking on the same level of the PROJECTS folder. Basically a "BACKUP" folder under the MAIN folder, or it would be fine under the "PROJECTS" folder too, but if we did that we would have to "exclude" it from being a target when processing the macro, because I enter the "PROJECTS" folder as the entry folder when you prompt me in the macro. So just food for thought.

As you DID a FANTASTIC job at this seemingly impossible task of ADDING rows to multiple files in multiple directories... so mission ACCOMPLISHED!

If you are a willing sole and can take my continued challenge, would we be able to have a DELETE row macro? (I understand if you said enough already ) Please feel free to say so...

This would basically allow us to either ADD a Row or DELETE a Row to the MASTER and update all the TARGET files. (I realize at this point it would one or the other at a time, basically two (2) macros?) (i.e. we could not both add a row and erase antoher row at the same time in the MASTER and then run a macro... we would have to do one function and run the ADD Macro then the other function run the DELETE Macro...)

 

[b.downey]

I have added a Input box that allow you to specify the Folder Depth

I had disable the "BackUp" function when I was debugging the code and never re-enabled it. The foolowing code does have it operational, but I changed the way it works to meet your specs of having all the the backup in a "Backup" directory in the folder selected from the Dialog Box.

I had originally thougth it better to have a backup folder for each transitioned folder to account for duplicate files that may be present between folder levels. I also thought it would be easier to get the files restored to the right subfolder is there was an issue. Having everything in one BackFolder makes it more difficult to restore the backup files.

Here is the Code

Option Explicit
Dim FolderDepth As Integer
Dim BackupFilePath As String
'Dim wsResults As Worksheet
Sub Process()
    Dim fd As FileDialog
    Dim FilePath As String
    
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    With fd
        .AllowMultiSelect = False
        .Show
    End With
    
    If fd.SelectedItems.Count <= 0 Then
        Exit Sub
    End If
    
    FolderDepth = Val(InputBox("Folder Depth?", , 3))
    If FolderDepth <= 0 Then FolderDepth = 1
    
    'Set wsResults = GetResultsWs(ThisWorkbook)
    
    FilePath = fd.SelectedItems(1) & "\"
    
    BackupFilePath = FilePath & "BackUp\"
    If Len(Dir(BackupFilePath, vbDirectory)) = 0 Then
        MkDir BackupFilePath
    End If
    
    Call ProcessDir(FilePath, 1)
    
    MsgBox "Complete", vbInformation
End Sub
Function ProcessDir(ByVal FilePath As String, ByVal Level As Integer)
    Dim FileName As String
    
    Dim DirList() As String
    
    Dim WbTrg As Workbook
    Dim ws As Worksheet
    
    Dim I As Long
    
    If Level > FolderDepth Then
        Exit Function
    End If
    
    Level = Level + 1
    
    FileName = Dir(FilePath & "*project.xlsx")
    Do While Len(FileName) > 0
        FileCopy FilePath & FileName, BackupFilePath & FileName
        Call ProcessFile(FilePath & FileName)
        
        'Get next directory entry
        FileName = Dir()
    Loop
    
    'Now recursevly process sub-directories
    Call GetSubDirs(FilePath, DirList)
    For I = 1 To UBound(DirList)
        Call ProcessDir(DirList(I) & "\", Level)
    Next I
End Function
Function ProcessFile(ByVal FileName As String)
    Dim WbTrg As Workbook
    
    'Open the Target Workbook as Read only
    Workbooks.Open FileName:=FileName, ReadOnly:=False, UpdateLinks:=False
    Set WbTrg = ActiveWorkbook
    'WbTrg.SaveCopyAs BackupFilePath & WbTrg.Name
        
    'Call WriteResults(wsResults, "Processing File: " & FileName)
    Call ModifyTrgWs(WbTrg.Worksheets(1))
    
    'Close the Target WorkBook
    WbTrg.Close SaveChanges:=True
End Function
Function GetSubDirs(ByVal FilePath As String, DirList() As String)
    Dim FileName As String
    Dim DirCnt As Long
    
    ReDim DirList(0)
    
    FileName = Dir(FilePath, vbDirectory)
    Do While Len(FileName) > 0
        Select Case LCase(FileName)
            Case ".", "..", "backup"
                'Ignore
            Case Else
                If GetAttr(FilePath & FileName) And vbDirectory Then
                    DirCnt = DirCnt + 1
                    ReDim Preserve DirList(DirCnt)
                    DirList(DirCnt) = FilePath & FileName
                End If
        End Select
        FileName = Dir
        DoEvents
    Loop
End Function
Function WriteResults(wsResults As Worksheet, s As String)
    Dim RowNo As Long
    RowNo = wsResults.Range("A" & wsResults.Rows.Count).End(xlUp).Row + 1
    
    wsResults.Cells(RowNo, "A") = Now()
    wsResults.Cells(RowNo, "B") = s
End Function
Function GetResultsWs(wb As Workbook) As Worksheet
    Const SheetName As String = "Results"
    Dim ws As Worksheet
    
    For Each ws In wb.Worksheets
        If ws.Name = SheetName Then
            Set GetResultsWs = ws
            Exit Function
        End If
    Next
    
    wb.Sheets.Add After:=Worksheets(Worksheets.Count)
    wb.ActiveSheet.Name = SheetName
End Function
Function ModifyTrgWs(wsTrg As Worksheet)
    Dim wsMst As Worksheet
    
    Dim MstRow As Long
    Dim TrgRow As Long
    
    Set wsMst = ThisWorkbook.Sheets(1)
    
    TrgRow = 1
    For MstRow = 1 To wsMst.Range("A" & wsMst.Rows.Count).End(xlUp).Row
        If wsMst.Cells(MstRow, 1) <> wsTrg.Cells(TrgRow, 1) Then
            wsMst.Rows(MstRow).Copy
            wsTrg.Rows(TrgRow).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        End If
        TrgRow = TrgRow + 1
    Next MstRow
End Function

I am glad the insert is working weel for you. Based on your ability to undersand the code to date, you should get back into it

I'll take a look at the delete function to determine if it can be done.

 

[b.downey]

I have add the "DeleteRow" function

Option Explicit
Dim FolderDepth As Integer
Dim BackupFilePath As String
Dim Fnct As String
'Dim wsResults As Worksheet
Sub AddRows()
    Call Process("A")
End Sub
Sub DeleteRows()
    Call Process("D")
End Sub
Sub Process(ByVal strFnct As String)
    Dim fd As FileDialog
    Dim FilePath As String
    
    Fnct = strFnct
    
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    With fd
        .AllowMultiSelect = False
        .Show
    End With
    
    If fd.SelectedItems.Count <= 0 Then
        Exit Sub
    End If
    
    FolderDepth = Val(InputBox("Folder Depth?", , 3))
    If FolderDepth <= 0 Then FolderDepth = 1
    
    'Set wsResults = GetResultsWs(ThisWorkbook)
    
    FilePath = fd.SelectedItems(1) & "\"
    
    BackupFilePath = FilePath & "BackUp\"
    If Len(Dir(BackupFilePath, vbDirectory)) = 0 Then
        MkDir BackupFilePath
    End If
    
    Call ProcessDir(FilePath, 1)
    
    MsgBox "Complete", vbInformation
End Sub
Function ProcessDir(ByVal FilePath As String, ByVal Level As Integer)
    Dim FileName As String
    
    Dim DirList() As String
    
    Dim WbTrg As Workbook
    Dim ws As Worksheet
    
    Dim I As Long
    
    If Level > FolderDepth Then
        Exit Function
    End If
    
    Level = Level + 1
    
    FileName = Dir(FilePath & "*project.xlsx")
    Do While Len(FileName) > 0
        FileCopy FilePath & FileName, BackupFilePath & FileName
        Call ProcessFile(FilePath & FileName)
        
        'Get next directory entry
        FileName = Dir()
    Loop
    
    'Now recursevly process sub-directories
    Call GetSubDirs(FilePath, DirList)
    For I = 1 To UBound(DirList)
        Call ProcessDir(DirList(I) & "\", Level)
    Next I
End Function
Function ProcessFile(ByVal FileName As String)
    Dim WbTrg As Workbook
    
    'Open the Target Workbook as Read only
    Workbooks.Open FileName:=FileName, ReadOnly:=False, UpdateLinks:=False
    Set WbTrg = ActiveWorkbook
        
    'Call WriteResults(wsResults, "Processing File: " & FileName)
    Select Case UCase(Fnct)
        Case "A"
            Call TrgWsRowsAdd(WbTrg.Worksheets(1))
        Case "D"
            Call TrgWsRowsDelete(WbTrg.Worksheets(1))
    End Select
    
    'Close the Target WorkBook
    WbTrg.Close SaveChanges:=True
End Function
Function GetSubDirs(ByVal FilePath As String, DirList() As String)
    Dim FileName As String
    Dim DirCnt As Long
    
    ReDim DirList(0)
    
    FileName = Dir(FilePath, vbDirectory)
    Do While Len(FileName) > 0
        Select Case LCase(FileName)
            Case ".", "..", "backup"
                'Ignore
            Case Else
                If GetAttr(FilePath & FileName) And vbDirectory Then
                    DirCnt = DirCnt + 1
                    ReDim Preserve DirList(DirCnt)
                    DirList(DirCnt) = FilePath & FileName
                End If
        End Select
        FileName = Dir
        DoEvents
    Loop
End Function
Function WriteResults(wsResults As Worksheet, s As String)
    Dim RowNo As Long
    RowNo = wsResults.Range("A" & wsResults.Rows.Count).End(xlUp).Row + 1
    
    wsResults.Cells(RowNo, "A") = Now()
    wsResults.Cells(RowNo, "B") = s
End Function
Function GetResultsWs(wb As Workbook) As Worksheet
    Const SheetName As String = "Results"
    Dim ws As Worksheet
    
    For Each ws In wb.Worksheets
        If ws.Name = SheetName Then
            Set GetResultsWs = ws
            Exit Function
        End If
    Next
    
    wb.Sheets.Add After:=Worksheets(Worksheets.Count)
    wb.ActiveSheet.Name = SheetName
End Function
Function TrgWsRowsAdd(wsTrg As Worksheet)
    Dim wsMst As Worksheet
    
    Dim MstRow As Long
    Dim TrgRow As Long
    
    Set wsMst = ThisWorkbook.Sheets(1)
    
    TrgRow = 1
    For MstRow = 1 To wsMst.Range("A" & wsMst.Rows.Count).End(xlUp).Row
        If wsMst.Cells(MstRow, 1) <> wsTrg.Cells(TrgRow, 1) Then
            wsMst.Rows(MstRow).Copy
            wsTrg.Rows(TrgRow).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        End If
        TrgRow = TrgRow + 1
    Next MstRow
End Function
Function TrgWsRowsDelete(wsTrg As Worksheet)
    Dim wsMst As Worksheet
    Dim MstRow As Long
    Set wsMst = ThisWorkbook.Sheets(1)
    MstRow = 1
    
    Do While MstRow <= wsMst.Range("A" & wsMst.Rows.Count).End(xlUp).Row
        'Debug.Print MstRow
        'Debug.Print wsMst.Cells(MstRow, 1), wsTrg.Cells(MstRow, 1)
        If wsMst.Cells(MstRow, 1) <> wsTrg.Cells(MstRow, 1) Then
            wsTrg.Rows(MstRow).Delete Shift:=xlUp
        Else
            MstRow = MstRow + 1
        End If
    Loop
    
    'Remove any extra rows that are in the target but not the master
    Do While MstRow <= wsTrg.Range("A" & wsTrg.Rows.Count).End(xlUp).Row
        wsTrg.Rows(MstRow).Delete Shift:=xlUp
    Loop
End Function

 

[ita]

Awesome! I'm out of town tomorrow full day, but will try this out when I can and let you know. Much Thanks!

 

[ita]

Hey Brian I'm back in town... much longer issues everywhere. But I did not want you to think I have forgotten this.

I will have some time early next week to try this. BTW this is in a "SharePoint" site. So I may have to think about the folder structure naming conventions when I go live with this.

I'll be in touch again.

 

[ita]

Hey Brian I'm back in town... much longer issues everywhere. But I did not want you to think I have forgotten this.

I will have some time early next week to try this. BTW this is in a "SharePoint" site. So I may have to think about the folder structure naming conventions when I go live with this.

I'll be in touch again.