Macro for cutting data, creating a new file with a prescribed filename, with multiple tabs

Brirack77 

Maybe this code will help you a bit or you can adapt it to your project.

VBA Code is untested backup your file first.

Sub SplitDataByRegion()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim uniqueRegions As Collection
    Dim region As Variant
    Dim outputFolder As String
    Dim lastRow1 As Long, lastRow2 As Long
    Dim newWorkbook As Workbook
    Dim outputFileName As String
    Dim regionColumn As String
    Dim wsNew1 As Worksheet, wsNew2 As Worksheet
    
    ' Set references to the two worksheets
    Set ws1 = ThisWorkbook.Sheets("Sheet1")
    Set ws2 = ThisWorkbook.Sheets("Sheet2")
    
    ' Set output folder path (ensure it exists)
    outputFolder = "C:\YourOutputFolder\" ' Modify to your path

    ' Specify the column that holds the Region numbers (e.g., "A")
    regionColumn = "A" ' Modify this if the Region is in a different column

    ' Get unique Regions from both sheets
    Set uniqueRegions = New Collection
    On Error Resume Next ' Ignore errors for duplicate items
    lastRow1 = ws1.Cells(ws1.Rows.Count, regionColumn).End(xlUp).Row
    lastRow2 = ws2.Cells(ws2.Rows.Count, regionColumn).End(xlUp).Row

    ' Loop through regions in Sheet1
    For Each cell In ws1.Range(regionColumn & "2:" & regionColumn & lastRow1)
        If cell.Value <> "" Then uniqueRegions.Add cell.Value, CStr(cell.Value)
    Next cell

    ' Loop through regions in Sheet2
    For Each cell In ws2.Range(regionColumn & "2:" & regionColumn & lastRow2)
        If cell.Value <> "" Then uniqueRegions.Add cell.Value, CStr(cell.Value)
    Next cell
    On Error GoTo 0 ' Resume normal error handling

    ' Loop through each unique Region
    For Each region In uniqueRegions
        ' Create a new workbook with two sheets
        Set newWorkbook = Workbooks.Add
        Set wsNew1 = newWorkbook.Sheets(1) ' First sheet in new workbook
        wsNew1.Name = "Sheet1"

        ' Copy filtered data from Sheet1 to the new workbook
        ws1.Rows(1).Copy Destination:=wsNew1.Rows(1) ' Copy header row
        ws1.Rows(2 & ":" & lastRow1).AutoFilter Field:=1, Criteria1:=region
        ws1.Range("A2:Z" & lastRow1).SpecialCells(xlCellTypeVisible).Copy _
            Destination:=wsNew1.Range("A2")
        ws1.AutoFilterMode = False ' Clear filter

        ' Add a second sheet in the new workbook for Sheet2 data
        If newWorkbook.Sheets.Count < 2 Then newWorkbook.Sheets.Add after:=wsNew1
        Set wsNew2 = newWorkbook.Sheets(2)
        wsNew2.Name = "Sheet2"

        ' Copy filtered data from Sheet2 to the new workbook
        ws2.Rows(1).Copy Destination:=wsNew2.Rows(1) ' Copy header row
        ws2.Rows(2 & ":" & lastRow2).AutoFilter Field:=1, Criteria1:=region
        ws2.Range("A2:Z" & lastRow2).SpecialCells(xlCellTypeVisible).Copy _
            Destination:=wsNew2.Range("A2")
        ws2.AutoFilterMode = False ' Clear filter

        ' Save the new workbook with a prescribed name
        outputFileName = outputFolder & "Region_" & region & ".xlsx"
        newWorkbook.SaveAs Filename:=outputFileName, FileFormat:=xlOpenXMLWorkbook
        
        ' Close the new workbook
        newWorkbook.Close SaveChanges:=False
    Next region
End Sub

The macro uses AutoFilter to filter rows based on the "Region" column.

The outputFolder should be a valid path on your system where you want the new files to be saved.

Ensure that the region column is the same on both sheets (adjust regionColumn if needed).

The code assumes that the data you want to copy is within columns "A" to "Z" (Range("A2:Z")), which you can adjust according to your data layout.

My answers are voluntary and without guarantee!

Hope this will help you.