VBA - Split data of two worksheets into same excel

Question

I have an excel file serving as a database with two worksheets, each with a table. Both tables have column A (Region) in common. Every Monday I must split this data, which has a few thousand lines, by Region, so I end up with about 30 files, each with the two sheets mentioned above, filtered for the respective region.

This is clearly inefficient, so I want to automate this process. At the moment I was able to come up with a macro that does automatically split the data, however only for the 1st worksheet, I am not being able to incorporate the data in the 2nd sheet as well.

Below is my current code working for splitting the data by the values in column A (Region) only in the 1st sheet :

Sub Split_Files()
    
    Const aibPrompt As String = "Which column would you like to filter by?"
    Const aibtitle As String = "Filter Column"
    Const aibDefault As Long = 1
    
    Dim dFileExtension As String: dFileExtension = ".xlsx"
    Dim dFileFormat As XlFileFormat: dFileFormat = xlOpenXMLWorkbook
    Dim dFolderPath As String: dFolderPath = "XYZ"
    
    If Right(dFolderPath, 1) <> "\" Then dFolderPath = dFolderPath & "\"
    If Len(Dir(dFolderPath, vbDirectory)) = 0 Then Exit Sub ' folder not found
    If Left(dFileExtension, 1) <> "." Then dFileExtension = "." & dFileExtension
    
    Application.ScreenUpdating = False
    
    Dim sCol As Variant
    sCol = Application.InputBox(aibPrompt, aibtitle, aibDefault, , , , , 1)
    If Len(CStr(sCol)) = 0 Then Exit Sub ' no entry
    If sCol = False Then Exit Sub ' canceled
    
    Dim sws As Worksheet: Set sws = ThisWorkbook.Worksheets("Sheet1")
    If sws.FilterMode Then sws.ShowAllData
    Dim srg As Range: Set srg = sws.Range("A1").CurrentRegion
    Dim srCount As Long: srCount = srg.Rows.Count
    If srCount < 3 Then Exit Sub ' not enough rows
    Dim srrg As Range: Set srrg = srg.Rows(1) ' to copy column widths
    Dim scrg As Range: Set scrg = srg.Columns(sCol)
    Dim scData As Variant: scData = scrg.Value
    
    ' Write the unique values from the 1st column to a dictionary.
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare ' case insensitive
    
    Dim Key As Variant
    Dim r As Long
    
    For r = 2 To srCount
        Key = scData(r, 1)
        If Not IsError(Key) Then ' exclude error values
            If Len(Key) > 0 Then ' exclude blanks
                dict(Key) = Empty
            End If
        End If
    Next r
    If dict.Count = 0 Then Exit Sub ' only error values and blanks
    Erase scData
    
    Dim dwb As Workbook
    Dim dws As Worksheet
    Dim dfcell As Range
    Dim dFilePath As String
    
    For Each Key In dict.Keys
        ' Add a new (destination) workbook and reference the first cell.
        Set dwb = Workbooks.Add(xlWBATWorksheet) ' one worksheet
        Set dws = dwb.Worksheets(1)
        Set dfcell = dws.Range("A1")
        ' Copy/Paste
        srrg.Copy
        dfcell.PasteSpecial xlPasteColumnWidths
        srg.AutoFilter sCol, Key
        srg.SpecialCells(xlCellTypeVisible).Copy dfcell
        sws.ShowAllData
        dfcell.Select
        ' Save/Close
        dFilePath = dFolderPath & "Access Rights Review " & Key & dFileExtension ' build the file path
        Application.DisplayAlerts = False ' overwrite without confirmation
        dwb.SaveAs dFilePath, xlOpenXMLWorkbook
        Application.DisplayAlerts = True
        dwb.Close SaveChanges:=False
    Next Key
    
    sws.AutoFilterMode = False
    Application.ScreenUpdating = True
    
    MsgBox "Data exported.", vbInformation
    
End Sub

Kindly appreciate if anyone can advise on how to incorporate the 2nd worksheet table to be also split and added to the file of each region.

Many thanks.

Answer 1

Try this out - similar to your existing code but uses a Collection to hold the source worksheets.

Sub Split_Files()
    Const dFileExtension As String = ".xlsx"  'include "."
    Const dFolderPath As String = "C:\Temp\"  'include ending "\"
    
    Dim dict As Object, wsNum As Long, dws As Worksheet, sws As Worksheet, srg As Range
    Dim colWs As New Collection, ws As Worksheet, splitCol As Variant, fileExt
    Dim dwb As Workbook, dfcell As Range, dFilePath As String, folderpath, key
    
    'add the sheets to be split up
    colWs.Add ThisWorkbook.Worksheets("Sheet1")
    colWs.Add ThisWorkbook.Worksheets("Sheet2")
    
    splitCol = Application.InputBox("Which column would you like to filter by?", _
                                    "Filter Column", 1, , , , , 1)
    If Len(Trim(splitCol)) = 0 Then Exit Sub ' no entry
    If Not IsNumeric(splitCol) Then Exit Sub
    splitCol = CLng(splitCol) 'convert to number
    
    'collect unique values from the sheets to be split
    Set dict = CreateObject("scripting.dictionary")
    dict.CompareMode = vbTextCompare ' case insensitive
    For Each sws In colWs
        If sws.FilterMode Then ws.ShowAllData
        Set dict = UniqueColumnValues(sws.Cells(2, splitCol), dict)
    Next sws
    If dict.Count = 0 Then Exit Sub ' only error values and blanks
    
    Application.ScreenUpdating = False
    
    For Each key In dict.Keys
        Set dwb = Workbooks.Add(xlWBATWorksheet) ' one worksheet
        Set dws = dwb.Worksheets(1)
        wsNum = 0 'reset destination sheet index
        For Each sws In colWs
            wsNum = wsNum + 1
            If wsNum > dwb.Worksheets.Count Then dwb.Worksheets.Add after:=dws
            Set dws = dwb.Worksheets(wsNum)
            dws.Name = sws.Name
            
            Set srg = sws.Range("A1").CurrentRegion
            srg.Rows(1).Copy
            dws.Range("A1").PasteSpecial xlPasteColumnWidths
            If srg.Rows.Count > 3 Then
                srg.AutoFilter splitCol, key
                srg.SpecialCells(xlCellTypeVisible).Copy dws.Range("A1")
                sws.ShowAllData
            End If
        Next sws
        
        dFilePath = dFolderPath & "Access Rights Review " & key & dFileExtension ' build the file path
        Application.DisplayAlerts = False ' overwrite without confirmation
        dwb.SaveAs dFilePath, xlOpenXMLWorkbook
        Application.DisplayAlerts = True
        dwb.Close SaveChanges:=False
    Next key
    
    Application.ScreenUpdating = True
    MsgBox "Data exported.", vbInformation
End Sub

'Collect unique values in column, starting at `startCell` until last occupied cell
'   in that column.  Optionally append those values into a supplied dictionary object.
Function UniqueColumnValues(startCell As Range, Optional dict As Object = Nothing)
    Dim c As Range, arr, r As Long, v
    If dict Is Nothing Then Set dict = CreateObject("scripting.dictionary")
    With startCell.Worksheet
        'read all values to an array (faster than cell-by-cell looping)
        arr = .Range(startCell, .Cells(Rows.Count, startCell.Column).End(xlUp)).Value
    End With
    For r = 1 To UBound(arr, 1)
        v = arr(r, 1)
        If Not IsError(v) Then
            If Len(v) > 0 Then
                dict(v) = True
            End If 'not blank
        End If     'not an error
    Next r
    Set UniqueColumnValues = dict
End Function