Split Excel Workbook to separate .xlsx files for each unique value in Column A, also copy worksheet for Drop Down reference

[MrMaloner]

Hi guys,

I've gotten pretty far using some tutorials found online, but getting stuck on the multiple worksheet/dropdown reference piece.

I've got the below VBA macro which successfully splits my workbook into multiple .xlsx files based on Column A. However, I have Columns D and E with dropdown lists referencing a separate worksheet for their values.

I have been unable to figure out how to get the "DropDowns" worksheet to copy over to the new files during the split process.

Anyone able to give me a hand or at least tell me its not possible? Maybe a better workaround to reference the dropdowns on the new sheets without manual intervention?

Option Explicit

Const Target_Folder As String = ""
Dim wsSource As Worksheet, wsHelper As Worksheet
Dim LastRow As Long, LastColumn As Long

Sub SplitDataset()
    
    Dim collectionUniqueList As Collection
    Dim i As Long
    
    Set collectionUniqueList = New Collection
    
    Set wsSource = ThisWorkbook.Worksheets("MasterList")
    Set wsHelper = ThisWorkbook.Worksheets("Helper")
    
    ' Clear Helper Worksheet
    wsHelper.Cells.ClearContents
    
    With wsSource
        .AutoFilterMode = False
        
        LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
        LastColumn = .Cells(1, Columns.Count).End(xlToLeft).Column
        
        If .Range("A2").Value = "" Then
            GoTo Cleanup
        End If
        
        Call Init_Unique_List_Collection(collectionUniqueList, LastRow)
        
        Application.DisplayAlerts = False
        
        For i = 1 To collectionUniqueList.Count
                SplitWorksheet (collectionUniqueList.Item(i))
        Next i
        
        ActiveSheet.AutoFilterMode = False
        
    End With

Cleanup:

    Application.DisplayAlerts = True
    Set collectionUniqueList = Nothing
    Set wsSource = Nothing
    Set wsHelper = Nothing

End Sub

Private Sub Init_Unique_List_Collection(ByRef col As Collection, ByVal SourceWS_LastRow As Long)
    
    Dim LastRow As Long, RowNumber As Long
    
    ' Unique List Column
    wsSource.Range("A2:A" & SourceWS_LastRow).Copy wsHelper.Range("A1")
    
    With wsHelper
        
        If Len(Trim(.Range("A1").Value)) > 0 Then
            
            LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
            
            .Range("A1:A" & LastRow).RemoveDuplicates 1, xlNo
            
            LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
            
            .Range("A1:A" & LastRow).Sort .Range("A1"), Header:=xlNo
            
            LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
            
            On Error Resume Next
            For RowNumber = 1 To LastRow
                col.Add .Cells(RowNumber, "A").Value, CStr(.Cells(RowNumber, "A").Value)
            Next RowNumber
          
        End If
    
    End With
    
End Sub

Private Sub SplitWorksheet(ByVal Category_Name As Variant)
    
    Dim wbTarget As Workbook
    
    Set wbTarget = Workbooks.Add
    
    With wsSource
        
        With .Range(.Cells(1, 1), .Cells(LastRow, LastColumn))
            .AutoFilter .Range("A1").Column, Category_Name
            
            .Copy
        
            
             wbTarget.Worksheets(1).PasteSpecial xlPasteColumnWidths
             wbTarget.Worksheets(1).Paste
             wbTarget.Worksheets(1).Name = Category_Name
            
        
            Call Retain_Formula(wbTarget)
            
            wbTarget.SaveAs Target_Folder & Category_Name & "_2025 Monthly Invoice Schedule Worksheet" & ".xlsx", 51
            wbTarget.Close False
            
        End With
        
    End With
    
    Set wbTarget = Nothing
    
End Sub

Private Sub Retain_Formula(ByVal wb_object As Workbook)
    
    '// assuming dataset always starts at row 2
    Dim col_index As Long, target_ws_lastrow As Long
    
    For col_index = 1 To LastColumn
        
        If wsSource.Cells(2, col_index).HasFormula Then
            '// transport formula
            wb_object.Worksheets(1).Cells(2, col_index).Formula = wsSource.Cells(2, col_index).Formula
            
            '// autofill formula to the last row
            target_ws_lastrow = wb_object.Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row
            With wb_object.Worksheets(1)
                .Range(.Cells(2, col_index), .Cells(target_ws_lastrow, col_index)).Formula = .Cells(2, col_index).Formula
            End With
                    
        End If
    Next col_index
    
End Sub

 

[Alex Blakenburg]

Show us the Data Validation Settings box.
If you are using Named Ranges it quite easy but if you are using hard coded ranges then it is much trickier.

 

[MrMaloner]

Show us the Data Validation Settings box.
If you are using Named Ranges it quite easy but if you are using hard coded ranges then it is much trickier.

Thanks for the reply Alex.

Data Validation source in the screenshot below

 

[Alex Blakenburg]

Any reason you don't use the more robust method of using a table combined with a range name.
See video here from the 3:03 min mark.

 

[MrMaloner]

Any reason you don't use the more robust method of using a table combined with a range name.
See video here from the 3:03 min mark.

No reason at all, I was simply not familiar with named ranges prior to the video.

Updating my source workbook to use named ranges for the dropdown appears to have worked perfectly with the VBA macro above. Expected lists are copied and available in the dropdowns of the new workbooks. Thank you!

 

[Alex Blakenburg]

You will need to add some code to copy the DropDowns sheet to the newly created workbooks.
If you don't do that you will be linking the new workbook to the original workbook and that will cause you nothing but trouble.

So at the start of your code add the lines in blue:

Const Target_Folder As String = ""
Dim wsSource As Worksheet, wsHelper As Worksheet, wsDropdowns As Worksheet
Dim LastRow As Long, LastColumn As Long

Sub SplitDataset()
    
    Dim collectionUniqueList As Collection
    Dim i As Long
    
    Set collectionUniqueList = New Collection
    
    Set wsSource = ThisWorkbook.Worksheets("MasterList")
    Set wsHelper = ThisWorkbook.Worksheets("Helper")
    Set wsDropdowns = ThisWorkbook.Worksheets("Dropdowns")

and in your "SplitWorksheet" Sub add this line in blue:

             wbTarget.Worksheets(1).PasteSpecial xlPasteColumnWidths
             wbTarget.Worksheets(1).Paste
             wbTarget.Worksheets(1).Name = Category_Name
            
             wsDropdowns.Copy After:=wbTarget.Worksheets(wbTarget.Worksheets.Count) 

 

[MrMaloner]

Thank you again, Alex - that worked perfectly.

One question - the new group of workbooks open up to the "dropdowns" worksheet, which is irrelevant to the end user. Can you think of a way to default the new workbooks to open up to the first/main worksheet?

 

[Alex Blakenburg]

Before the SaveAs line, try putting this line:

            wbTarget.Worksheets(1).Select

 

[MrMaloner]

Once again, worked perfectly. You've saved my team and I hours. Thank you!!!

 

[Alex Blakenburg]

Thanks for the feedback. Glad I could help.