VBA to save one file as multiple files in location

[bh24524]

Hello, I am looking for some code that will save a tab of one file as multiple files in a specific location. I have also posted this question here and I have basically half of a solution but am having trouble getting them to understand what I am after. I have a sample file with two tabs. Sheet1 contains a listing of numbers, names and departments as well as a key off to the side in columns L and M. They key lists all the departments there could possibly be(column L) and a brief description of them in column M. Sorry I can't usexl2bb to do this but company download policy is preventing it so I am using a screenshot. See pic below:

Sheet2 basically serves as a template that would be printed. It has a drop-down menu from data validation in cell B8 which is taken from the Key in sheet1. Here is a pic of Sheet2

B7 just has a simple lookup for the dept description base don what is chosen in B8. Changing selections in B8 will also change names that are populated in row 11 and onwards:

What I am looking to do is have a macro that will select each of the choices in the menu in B8 of this sheet and then save a copy of sheet2 as a specific name in a specific location. The location can simply be a folder called sample on the desktop(I will alter the path to what I truly need but for simplicity sake this can be used) The file name will be specific to what is in cells B7 and B8. So if we look at the second screenshot where I have "Test1" selected, the macro would save Sheet2 as a new file in that sample folder called "Test1 - 1st Shift" ("B8 - B7"). It would then select all the other departments in that list one by one saving each one as it's own file in the sample folder. So in my sample sheet, I have a total of 4 possible departments(There are more on the actual sheet but just keeping it simpler here) That will mean that 4 different files of sheet 2 get created in the folder and each one specific to the selection made in B8. The code I was given to help that is doing half of what I need and is as follows if it will help as a guiding point:

Option Explicit

Sub PitchNinja_v2()
    Dim i As Long, j As Long, jj As Long
    Dim wsSource    As Worksheet: Set wsSource = ThisWorkbook.Worksheets("Sheet1")

    Dim FolderPath  As String: FolderPath = "D:\Sample\"
    Application.ScreenUpdating = False

    If Len(Dir(FolderPath, vbDirectory)) = 0 Then
        MkDir FolderPath
    End If

    For i = 2 To wsSource.Cells(wsSource.Rows.Count, 3).End(xlUp).Row
        Dim iDept   As String: iDept = wsSource.Cells(i, 3).Value
        Dim NewWorkbook As Workbook: Set NewWorkbook = Workbooks.Add
        Dim NewBookRow As Long: NewBookRow = 1
        wsSource.Cells(1, 1).Resize(, 2).Copy NewWorkbook.Worksheets(1).Cells(NewBookRow, 1)

        For j = 2 To wsSource.Cells(wsSource.Rows.Count, 1).End(xlUp).Row

            If wsSource.Cells(j, 3).Value = iDept Then

                For jj = 2 To wsSource.Cells(wsSource.Rows.Count, 13).End(xlUp).Row
                    Dim iRng As Range: Set iRng = wsSource.Columns("L:L").Find(What:=iDept, LookIn:=xlValues, LookAt:=xlWhole)

                    If Not iRng Is Nothing Then
                        Dim iKey As String: iKey = iRng.Offset(0, 1).Value
                    End If

                Next jj

                wsSource.Cells(j, 1).Resize(, 2).Copy NewWorkbook.Worksheets(1).Cells(NewBookRow + 1, 1)
                NewWorkbook.Worksheets(1).Columns("A:B").AutoFit
                NewBookRow = NewBookRow + 1
            End If
        
        Next j

        Dim FileName As String: FileName = FolderPath & iDept & " - " & iKey & ".xlsx"
        Application.DisplayAlerts = False
        NewWorkbook.SaveAs FileName, FileFormat:=51
        Application.DisplayAlerts = True
        NewWorkbook.Close SaveChanges:=False
    Next i

    Application.ScreenUpdating = True
    MsgBox "Done!", vbInformation
End Sub

This code is functioning correct in that it is saving correct amount of files to the specified location. It however is saving the wrong tab. It is saving Sheet1 not sheet2 which is what I have tried explaining. I am not sure how VBA handles selecting menu choices from a data validation menu, but if it is easier for coding, the selections could simply be copied from Sheet1 in column L and then pasted into B8 of Sheet2 and then have Sheet2 saved to the folder. I hope this made sense. Please let me know if this is doable and if any questions.

 

[John_w]

It is saving Sheet1 not sheet2

Because you reference Sheet1 as wsSource and then only copy from wsSource to the new workbooks:

Set wsSource = ThisWorkbook.Worksheets("Sheet1")
wsSource.Cells(1, 1).Resize(, 2).Copy NewWorkbook.Worksheets(1).Cells(NewBookRow, 1)
wsSource.Cells(j, 1).Resize(, 2).Copy NewWorkbook.Worksheets(1).Cells(NewBookRow + 1, 1)

Nowhere in the code do you copy from Sheet2.

Here's another approach:

Public Sub Create_xlsx_Files()

    Dim destinationFolder As String
    Dim dataValidationCell As Range, dataValidationListSource As Range, dvValueCell As Range
   
    destinationFolder = "C:\path\to\folder\"   'CHANGE THIS
   
    If Right(destinationFolder, 1) <> "\" Then destinationFolder = destinationFolder & "\"
        
    'Cell containing data validation in-cell dropdown
   
    Set dataValidationCell = ThisWorkbook.Worksheets("Sheet2").Range("B8")
    
    'Source of data validation list
   
    Set dataValidationListSource = Evaluate(dataValidationCell.Validation.Formula1)
    
    Application.ScreenUpdating = False
   
    'Create XLSX for each data validation value
   
    For Each dvValueCell In dataValidationListSource
   
        dataValidationCell.Value = dvValueCell.Value
       
        With ThisWorkbook.Worksheets("Sheet2")
            .Copy
            ActiveWorkbook.Worksheets("Sheet2").UsedRange.Value = ActiveWorkbook.Worksheets("Sheet2").UsedRange.Value  'change formulas to values
            Application.DisplayAlerts = False 'suppress prompt if .xlsx file already exists - the file is replaced
            ActiveWorkbook.SaveAs FileName:=destinationFolder & .Range("B7").Value & " - " & .Range("B8").Value & ".xlsx", FileFormat:=xlOpenXMLWorkbook
            Application.DisplayAlerts = True
            ActiveWorkbook.Close SaveChanges:=False
        End With
       
    Next
       
    Application.ScreenUpdating = True
   
    MsgBox "Done", vbInformation
       
End Sub

 

[bh24524]

Thank you very much John! this is exactly what I am after. I have 44 departments in my Actual file and sure enough, I got 44 files created in the folder. This is excellent! One thing I did want to ask though is if we could make a small addition to the code i just thought of after running this. I love that this macro is pasting values into the new workbooks it creates - that will be very helpful. I am wondering if after it pastes the values if it could actually then sort cells A11:E42 first by Column C and then by column D for each file? The screenshots I initially posted from my sample file do not have any data in C thru E but the actual file does. I just left them out of the sample file to try and keep it as simple as possible, but if it could also do that sorting, that would be tremendously helpful. Let me know

 

[John_w]

I am wondering if after it pastes the values if it could actually then sort cells A11:E42 first by Column C and then by column D for each file?

It's easy enough to record a macro to do the sorting and incorporate the generated code into the previous macro, like this:

Public Sub Create_xlsx_Files()

    Dim destinationFolder As String
    Dim dataValidationCell As Range, dataValidationListSource As Range, dvValueCell As Range
   
    destinationFolder = "C:\path\to\folder\"  'CHANGE THIS
   
    If Right(destinationFolder, 1) <> "\" Then destinationFolder = destinationFolder & "\"
        
    'Cell containing data validation in-cell dropdown
   
    Set dataValidationCell = ThisWorkbook.Worksheets("Sheet2").Range("B8")
    
    'Source of data validation list
   
    Set dataValidationListSource = Evaluate(dataValidationCell.Validation.Formula1)
    
    Application.ScreenUpdating = False
   
    'Create .xlsx file containing Sheet2 for each data validation value
   
    For Each dvValueCell In dataValidationListSource
   
        dataValidationCell.Value = dvValueCell.Value
       
        With ThisWorkbook.Worksheets("Sheet2")
            .Copy
            With ActiveWorkbook.Worksheets("Sheet2")
                'Change formulas to values
                .UsedRange.Value = .UsedRange.Value
                'Sort A11:E42 by column C and D
                .Sort.SortFields.Clear
                .Sort.SortFields.Add2 Key:=Range("C11:C42"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
                .Sort.SortFields.Add2 Key:=Range("D11:D42"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
                With .Sort
                    .SetRange Range("A11:E42")
                    .Header = xlGuess
                    .MatchCase = False
                    .Orientation = xlTopToBottom
                    .SortMethod = xlPinYin
                    .Apply
                End With
            End With
            'Save .xlsx file
            Application.DisplayAlerts = False 'suppress prompt if .xlsx file already exists - the file is replaced
            ActiveWorkbook.SaveAs FileName:=destinationFolder & .Range("B7").Value & " - " & .Range("B8").Value & ".xlsx", FileFormat:=xlOpenXMLWorkbook
            Application.DisplayAlerts = True
            ActiveWorkbook.Close SaveChanges:=False
        End With
       
    Next
       
    Application.ScreenUpdating = True
   
    MsgBox "Done", vbInformation
       
End Sub

 

[bh24524]

Ah true forgot about that, my apologies. Thanks for the revision!

 

[bh24524]

Sorry John I do have one more question if you get a chance. I couldn't do this via recording since it would be dynamic for each sheet, but each sheet has a totals section that starts in row 43. On one sheets dept., names might only go down to Row 15, and another sheets dept. maybe down to 35. What line of coding could I insert in this sub-procedure that would delete all blank rows except one between the last populated name on any given sheet? Would this be something with "Offset" in the code?

 

[John_w]

each sheet has a totals section that starts in row 43. On one sheets dept., names might only go down to Row 15, and another sheets dept. maybe down to 35. What line of coding could I insert in this sub-procedure that would delete all blank rows except one between the last populated name on any given sheet?

Between these 2 lines:

                End With
            End With

Insert this code:

    Dim lastRow As Long
                'Find last populated cell above B43 and delete empty rows above row 42
                lastRow = .Range("B43").End(xlUp).Row + 1
                If lastRow < 42 Then
                    .Rows(lastRow & ":41").Delete Shift:=xlUp
                End If

 

[bh24524]

Just tested, thank you. That looks a LOT cleaner!