Macro to Make Copies of an Entire Workbook (with all tabs) Based on Unique Value in a Field

[JHCali]

Hi Everyone,

I am looking for a macro to automate the following sequence of events:

1. Create as many copies of a workbook (with all the tabs) as there are unique names in the Sales Rep field
2. Rename each file by adding “ – <Sales Rep First Name Last Name>” to the end of the filename
3. Open each file, filter the database on the Sales Rep field, and unselect the Sales Rep whose name is on the file. Delete all records, and clear the filter on the Sales Rep field so that the only records remaining are those for the Sales Rep whose name is on the file.
4. Select the “Pivot” tab in the workbook, select a cell in the pivot table, and select “Refresh All”
5. Hide the “Pivot” tab
6. Hide the “Data” tab
7. Select the “Dashboard” tab
8. Save and close the workbook
9. Repeat steps 3-8 for each workbook

Below are some specifics about the master workbook.

• There are three (3) tabs. A “Data” tab with all the data, a “Pivot” tab which uses pivot tables to summarize the data from the “Data” tab, and a “Dashboard” tab which creates graphs and charts from the pivot tables in the “Pivot” tab
• The Sales Rep column is column AA, and there are over 50 unique Sales Rep names, so that means over 50 copies.
• The Master workbook has the following naming convention – “Weekly Product Trend Report – YYYY.MM.DD”

With over 50 sales reps, repeating steps 3-8 over fifty (50) times can get tedious and time consuming, so I’m looking for any opportunity to automate and speed up the process.

Thank you all in advance for any help you can provide.

Regards,

 

[JHCali]

Hi mse330,

It is still taking a long time to run Part 2 of the macro even on just one file. It's been running for 5 minutes now and it still is not complete. I estimate that to do it manually takes about 30-45 seconds per file.

Regards,
JHCali

 

[mse330]

Hey JHCali,

Sorry I didn't have sufficient time yesterday to finish it off ... I have changed the code a bit & used dummy data of 50k rows & after changing the code I was able to reduce the time from 59 to 39 seconds for 5 files. Please delete the old code & use the revised code below & let me know how it goes.

If you still encounter issues, change the code to update 1 file similarly to what you did last time & if it takes time press escape button & then click debug & tell me where is it stuck

Regards

Public Duration As Single

Sub Part1()

Duration = Timer

With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
End With


'---- This section to check if there's an existing sheet called "Staff List" & if not create one
Dim ws As Worksheet

For Each ws In Worksheets
    If ws.Name = "Staff List" Then
            If MsgBox("There's an existing sheet with the name (Staff List), you have to delete it to continue. Do you wish to delete the sheet?", vbYesNo + vbExclamation) = vbYes Then
                Application.DisplayAlerts = False
                Sheets("Staff List").Delete
                Application.DisplayAlerts = True
            Else
                Exit Sub
            End If
    End If
Next ws

Sheets.Add.Name = "Staff List"


'---- Finding the last row in the main data sheet to select the staff names (assuming no blank cells in the middle)
Dim LastRow As Single
LastRow = Sheets("Data (No Dups, Internal)").Range("AV" & Rows.Count).End(xlUp).Row

With Sheets("Staff List")
    .Range("A1:A" & LastRow).Value = Sheets("Data (No Dups, Internal)").Range("AV1:AV" & LastRow).Value
    .Range("A1:A" & LastRow).RemoveDuplicates Columns:=1, Header:=xlNo
End With

LastRow = Sheets("Staff List").Range("A" & Rows.Count).End(xlUp).Row

'---- This section to save copies of the file based on each staff name
Dim CurrFilePath As String
Dim CurrFileName As String
Dim DeskTopPath As String
Dim NewFolderName As String

CurrFilePath = ActiveWorkbook.FullName
CurrFileName = Left(ThisWorkbook.Name, (InStrRev(ThisWorkbook.Name, ".", -1, vbTextCompare) - 1))
DeskTopPath = CreateObject("WScript.Shell").SpecialFolders("Desktop")
NewFolderName = "\Weekly Product Trend - " & Format(Date, "dd-mmm-yyyy")

'---- This is to create a new folder in desk top
If Len(Dir(DeskTopPath & NewFolderName, vbDirectory)) = 0 Then
   MkDir DeskTopPath & NewFolderName
Else
    If MsgBox("There's already an existing folder in desk top with the name :" & vbNewLine & NewFolderName, vbExclamation + vbYesNo) = vbYes Then
        On Error Resume Next
        Kill DeskTopPath & NewFolderName & "\*.*"
        RmDir DeskTopPath & NewFolderName
        MkDir DeskTopPath & NewFolderName
    Else
        Exit Sub
    End If
End If


'---- This section to save the files based on distinct staff names in the new created folder in desk top
Dim i As Double
For i = 2 To LastRow
    Dim CurrStaff As String
    CurrStaff = Sheets("Staff List").Range("A" & i).Value
    Sheets("Staff List").Range("B1").Value = CurrStaff
    ActiveWorkbook.SaveCopyAs DeskTopPath & NewFolderName & "\" & CurrFileName & " - " & CurrStaff & ".xlsb"
    Sheets("Staff List").Range("B" & i).Value = DeskTopPath & NewFolderName & "\" & CurrFileName & " - " & CurrStaff & ".xlsb"
Next i

With Application
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
End With

Call Part2

End Sub

Sub Part2()

With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
End With

Dim i As Double
Dim x As Double
Dim LastRow As Single
Dim StaffFileName As String
Dim CurrStaff As String

LastRow = Sheets("Staff List").Range("A" & Rows.Count).End(xlUp).Row


'---- In this section we will open each of the files that we have saved & make the necessary changes then save & close
For i = 2 To LastRow
    StaffFileName = Sheets("Staff List").Range("B" & i).Value
        If ActiveWorkbook.FullName <> StaffFileName Then
           Workbooks.Open StaffFileName
           CurrStaff = Sheets("Staff List").Range("B1").Value
           Sheets("Data (No Dups, Internal)").Activate
           
            '---- Array to find & delete data of other staff
            Dim DataLastRow As Single
            Dim DataLastCol As Single
            
            DataLastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
            DataLastCol = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column
 
            Dim Arr() As Variant
            Arr = ActiveSheet.Range("AV2:AV" & DataLastRow).Value
            
            For x = LBound(Arr) To UBound(Arr)
                If Arr(x, 1) <> CurrStaff Then
                    Arr(x, 1) = ""
                End If
            Next x
            
            ActiveSheet.Range("AV2:AV" & DataLastRow) = Arr()
            
            Dim Rg As Range
            Set Rg = ActiveSheet.Range(Cells(1, 1), Cells(DataLastRow, DataLastCol))

            Rg.Sort key1:=Range("AV2:AV" & DataLastRow), order1:=xlAscending, Header:=xlYes
                      
            Dim CurrStaffLastRow  As Single
            CurrStaffLastRow = ActiveSheet.Range("AV" & Rows.Count).End(xlUp).Row
            Rows(CurrStaffLastRow + 1 & ":" & DataLastRow).EntireRow.Delete
                 
           '---- Hide other sheets
           Sheets("Dashboard").Visible = xlSheetVisible
           Sheets("Setup").Visible = xlSheetVeryHidden
           Sheets("Data (No Dups, Internal)").Visible = xlSheetVeryHidden
           Sheets("Pivot").Visible = xlSheetVeryHidden
           
            Application.DisplayAlerts = False
                Sheets("Staff List").Delete
            Application.DisplayAlerts = True
           
           Sheets("Pivot").PivotTables("ProductHistoryPivot").RefreshTable
           
           With ActiveWorkbook
                .RefreshAll
                .Save
                .Close
           End With
        End If
Next i

Application.DisplayAlerts = False
    Sheets("Staff List").Delete
Application.DisplayAlerts = True

With Application
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
End With

Duration = (Timer - Duration) / 86400

MsgBox "Task completed successfuly ! You have " & LastRow - 1 & " files saved now" & vbNewLine & "Task completed in : " & Format(Duration, "HH:MM:SS"), vbInformation


End Sub

Private Sub ShowAll()

'---- This is for you to unhide all sheets in the workbook
Dim ws As Worksheet

For Each ws In Worksheets
    ws.Visible = xlSheetVisible
Next ws

End Sub

 

[JHCali]

mse330,

Words will never be able to adequately express how much more efficient your macro has made my work. Thank you thank you thank you so much! Your revised code worked beautifully and took what would have been a mundane and menial 2 hour task and turned it into an automated operation that runs in a matter of minutes.

Again, thank you so much!

Regards,
JHCali

 

[mse330]

Glad the revised code worked well for you ... You are more than welcome

 

[mse330]

So how long approx. the whole process takes now ?

 

[JHCali]

Approx. 8 minutes. For 70+ files.

 

[mse330]

Excellent, that's a good coffee brake