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,

 

[mse330]

JHCali, if you intend to hide all other sheets & show only the dashboard, could you send a PDF copy to each sales person then instead of any excel file ? Or is your dashboard dynamic ?

 

[Smitty]

Welcome to the Board!

The best place to start is with the Macro Recorder. Since you're already familiar with the manual process, it should be relatively easy. Granted, recorded code to this extent will need a lot of clean up, but you can post it back here for some help. The big part will be the For Each...Next loop you'll need to go through each sales rep name. The following code will loop through each name in a table called tbl_SalesReps on a sheet called Lists:

<font face=Calibri><SPAN style="color:#00007F">Sub</SPAN> LoopReps()<br>****<SPAN style="color:#00007F">Dim</SPAN> ws <SPAN style="color:#00007F">As</SPAN> Worksheet<br>****<SPAN style="color:#00007F">Dim</SPAN> lstObj <SPAN style="color:#00007F">As</SPAN> ListObject<br>****<SPAN style="color:#00007F">Dim</SPAN> strRep <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">String</SPAN><br>****<SPAN style="color:#00007F">Dim</SPAN> c <SPAN style="color:#00007F">As</SPAN> Range<br>****<br>****<SPAN style="color:#00007F">Set</SPAN> ws = Sheets("Lists")<br>****<SPAN style="color:#00007F">Set</SPAN> lstObj = ws.ListObjects("tbl_SalesReps")<br>****<br>****<SPAN style="color:#00007F">For</SPAN> <SPAN style="color:#00007F">Each</SPAN> c <SPAN style="color:#00007F">In</SPAN> lstObj.ListColumns(1).DataBodyRange<br>********strRep = c.Value<br>********Debug.Print strRep<br>****<SPAN style="color:#00007F">Next</SPAN> c<br>****<br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Sub</SPAN></FONT>

HTH

 

[JHCali]

Hi Guys,

Thanks for the replies. Mse330, the dashboard is dynamic and contains many splicers intended to help the Sales Reps dive into their results.

Smitty, I'll use Macro Recorder to record me doing the process for one workbook. Hopefully there is a way to adjust the code so that the macro automatically creates as many copies as there are sales reps and runs the process for each one. I'll endeavor to get this done tomorrow or Monday at the very latest.

Thanks so much for your help, both of you.

JHCali

 

[JHCali]

Hi Smitty,

Below is the code that I was able to generate using Record Macro. I am going to be running this report on a weekly basis, so the report name will change. I would like to define ReportStartDate and ReportEndDate and replace the filename portion of the code so it references ReportStartDate and ReportEndDate in place of the actual dates.

The goal is to have this code repeat for every unique sales rep in the master data, such that each sales rep ends up with a file that contains only their information. Also, the portion of the code that defines the data range will need to be modified so it automatically picks up the data range, since the amount of data on a week-to-week basis will be different.

Sub Macro1()'
' Macro1 Macro
'


'
    ChDir "C:\Users\jhashim\Desktop\Weekly Product Trend Report"
    Workbooks.Open Filename:= _
        "C:\Users\jhashim\Desktop\Weekly Product Trend Report\Weekly Product Trend Report - 2017.04.01 to 2017.06.23.xlsx" _
        , UpdateLinks:=0
    Sheets("Dashboard").Select
    Sheets("Setup").Visible = True
    Sheets("Setup").Select
    Sheets("Pivot").Visible = True
    Sheets("Pivot").Select
    Sheets("Data (No Dups, Internal)").Visible = True
    Range("AV1").Select
    ActiveWorkbook.Worksheets("Data (No Dups, Internal)").AutoFilter.Sort. _
        SortFields.Clear
    ActiveWorkbook.Worksheets("Data (No Dups, Internal)").AutoFilter.Sort. _
        SortFields.Add Key:=Range("AV1"), SortOn:=xlSortOnValues, Order:= _
        xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Data (No Dups, Internal)").AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    ActiveSheet.Range("$A$1:$BJ$23709").AutoFilter Field:=48, Criteria1:=Array( _
        "Anthony", "APAC", "Ashley", "Beth", "Brandon", _
        "Brian G", "Brian W", "Brianna", "Cindy", "Collin", _
        "Craig", "Darce", "David", "Elena", "EMEA", _
        "Erick", "Haley", "Heidi", "Isabelle", _
        "Jacob", "Jamie", "Jared", "Jarrel", _
        "Jason", "Jeffrey G", "Jeffrey N", "Jennifer", _
        "Jessica", "Jordan D", "Jordan M", "Josh", "Karen", _
        "Kathryn", "Katie", "Kevin", "Kim", _
        "Kristy", "Kyle V", "Kyle W", "LATAM", "Lauren", _
        "Leslie", "Lindsey B", "Lindsey S", "Markus", _
        "Mary K", "Mary S", "Matt D", "Matt T", _
        "Michael E", "Michael O", "Michelle", "Nichole" _
        , "Nicole B", "Nicole D", "NORA", "Peter", _
        "Portia", "Rachel", "Rebecca", "Russell", _
        "Ryne", "Sam", "Samantha K", "Samantha S", _
        "Sarah M", "Steven", "Tara", "Taylor", "Undetermined", _
        "Vacant"), Operator:=xlFilterValues
    Rows("677:677").Select
    Range("AG677").Activate
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Delete Shift:=xlUp
    Range("AV1").Select
    ActiveSheet.Range("$A$1:$BJ$676").AutoFilter Field:=48
    Sheets("Pivot").Select
    ActiveSheet.PivotTables("ProductHistoryPivot").PivotSelect _
        "'End of Week'['4/14/2017'] 'Effective Date'['4/8/2017']", xlDataAndLabel, True
    Range("F11").Select
    ActiveWorkbook.RefreshAll
    Sheets("Data (No Dups, Internal)").Select
    ActiveWindow.SelectedSheets.Visible = False
    Sheets("Pivot").Select
    ActiveWindow.SelectedSheets.Visible = False
    Sheets("Setup").Select
    ActiveWindow.SelectedSheets.Visible = False
    Range("A1").Select
    ActiveWorkbook.SaveAs Filename:= _
        "C:\Users\jhashim\Desktop\Weekly Product Trend Report\Weekly Product Trend Report - 2017.04.01 to 2017.06.23 - Amy.xlsx" _
        , FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    ActiveWindow.Close
End Sub

Thanks again so much for your help.

Regards,
JHCali

 

[mse330]

Hey JHCali

I have written the below code based on my understanding of your workbook. I tired to put comments in my code so you can follow through ... Here's what I am basically doing

Sub Part1
1. Create a new sheet called "Staff List" where I pick up all staff names from your "Data (No Dups, Internal)" sheet - Column AV
2. Remove all duplicates to have unique staff names
3. Create a new folder in your desktop
4. Make a loop to go through all staff names & save a workbook with the staff name in the newly created folder

Sub Part2
5. I open each of the new saved files
6. Clear data on all rows of other staff from sheet "Data (No Dups, Internal)"
7. Hide all sheets (xlSheetVeryHidden) which can only be un-hidden via VBA code
8. Refresh pivot table "ProductHistoryPivot" in sheet "Pivot"
9. Save & close the staff copy file

Please take a back up of your file before testing this code just in case something goes wrong. Note that you may need to change sheet names or staff names columns. If you have any questions or issues with the code, let me know

PS: I suggest that you protect your VBA code so others can not view it in their files

Enjoy :D

Sub Part1()

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
Dim DataLastRow As Single

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
           DataLastRow = Sheets("Data (No Dups, Internal)").Range("A" & Rows.Count).End(xlUp).Row

           '---- This section to delete all rows of other staff
           For x = 2 To DataLastRow
                If Sheets("Data (No Dups, Internal)").Range("AV" & x).Value <> CurrStaff Then
                    Rows(x & ":" & x).EntireRow.Clear
                End If
                'DataLastRow = Sheets("Data (No Dups, Internal)").Range("A" & Rows.Count).End(xlUp).Row
            Next x
                   
           '---- 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

MsgBox "Task completed successfuly ! You have " & LastRow - 1 & " files saved now", vbInformation


End Sub

 

[JHCali]

mse330,

Thank you so very much for that code! Part 1 works BEAUTIFULLY. It creates 73 files in under 5 minutes. AMAZING! I just had to make a couple of changes.

1. I added & "" to the following line of code:

[COLOR=#333333]NewFolderName = "\Weekly Product Trend - " & Format(Date, "dd-mmm-yyyy") & [/COLOR][B][COLOR=#ff0000]"\"[/COLOR][/B][COLOR=#333333][/COLOR]

With regard to Part 2, I ran into issues when the file extensions were .xlsb, because I got the error that the file could not be found or the extension was incorrect. So I changed the extension to .xlsm and this error went away. However, I now have the issue where it is taking a very long time to process one file. It has been running for 20 minutes now but the 1st of 73 files is still being processed. At first I thought this was because the data was not sorted by Sales Rep in the master file. So I sorted the master file by Sales Rep but this has not fixed the issue.

Do you know what could be causing Part 2 to run so slowly? The master file is approximately 25 megs and contains up to 30,000 rows. That is a lot of rows and a lot of columns, so I'm wondering if that could be causing the delay. Also, I'm curious as to why in your original code you specified .xlsb as the extension?

Thanks again so much for your help. You have no idea how much I appreciate it.

Regards,
JHCali

 

[mse330]

JHCali

Regarding your points:
1. I always save my files now in .xlsb format as it makes the file size smaller & opening time faster - Do some search about
2. When I did the code I used a very small data set (15 rows) so it was fine. In part 2, I am looping through all rows to find out the staff name then clear the data of the row if the staff name doesn't match the file staff name. It is 9 AM here in Kuwait & I am at work now but I will try to change the code in the evening to use arrays instead of looping through the cells which should make the process much quicker.

Regards

 

[JHCali]

Hi mse330,

Just a quick update. I now realize why you used .xlsb as the extension. It makes the file size much smaller. Now, Part 1 ran in less than a minute as opposed to 5 minutes when I changed the extension to .xlsm. To work with .xlsb, I made the master file a .xlsb, and this did NOT cause the error to show up which said that the file could not be found or the extension was incorrect. So no issues there.

Thanks so much for your help. I appreciate any help you can provide to speed up Part 2.

Regards,
JHCali

 

[mse330]

JHCali,

Can you try out something for me, in Part2 can you make the macro to run only for 1 file instead of all 72 files. I am curious to know how long it will take. What you need to do is to replace this part

'---- 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

with this

'---- 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 2 'LastRow

Regards