Untitled

Sub Split_Data_Into_Multiple_WORKBOOKS_Based_On_Column()
    Dim lr As Long
    Dim ws As Worksheet
    Dim vcol As Integer, i As Integer
    Dim icol As Long
    Dim myarr As Variant
    Dim title As String
    Dim titlerow As Integer
    Dim xTRg As Range
    Dim xVRg As Range
    Dim xWSTRg As Workbook
    Dim xWS As Worksheet
    Dim wb As Workbook
    Dim wbName As String
    Dim savePath As String ' Path to save the separated workbooks
    
    On Error Resume Next
    
    Set xTRg = Application.InputBox("Please select the header rows:", "", Type:=8)
    If TypeName(xTRg) = "Nothing" Then Exit Sub
    
    Set xVRg = Application.InputBox("Please select the column you want to split data based on:", "", Type:=8)
    If TypeName(xVRg) = "Nothing" Then Exit Sub
    
    vcol = xVRg.Column
    Set ws = xTRg.Worksheet
    lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
    title = xTRg.AddressLocal
    titlerow = xTRg.Cells(1).Row
    icol = ws.Columns.Count
    ws.Cells(1, icol) = "Unique"
    
    Application.DisplayAlerts = False
    
    Set xWSTRg = Workbooks.Add
    
    xTRg.Copy
    xWSTRg.Sheets(1).Range("A1").PasteSpecial xlPasteAll
    
    For i = (titlerow + xTRg.Rows.Count) To lr
        On Error Resume Next
        If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
            ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
        End If
    Next
    
    myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
    ws.Columns(icol).Clear
    
    ' Prompt the user to select the folder to save the separated workbooks
    savePath = BrowseForFolder("Select a folder to save the separated workbooks")
    
    For i = 2 To UBound(myarr)
        ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
        wbName = savePath & "\" & "Workbook_" & myarr(i) & ".xlsx" ' Update the file name based on the unique value in the column
        Set wb = Workbooks.Add
        wb.SaveAs Filename:=wbName, FileFormat:=xlOpenXMLWorkbook
        
        Set xWS = wb.Sheets(1)
        
        xTRg.Copy
        xWS.Range("A1").PasteSpecial xlPasteAll
        
        ws.Range("A" & (titlerow + xTRg.Rows.Count) & ":A" & lr).EntireRow.Copy xWS.Range("A" & (titlerow + xTRg.Rows.Count))
        
        xWS.Columns.AutoFit
        
        wb.Close SaveChanges:=True
    Next
    
    xWSTRg.Close SaveChanges:=False
    ws.AutoFilterMode = False
    ws.Activate
    Application.DisplayAlerts = True
End Sub

Function BrowseForFolder(Optional ByVal prompt As String) As String
    Dim shellApp As Object
    Set shellApp = CreateObject("Shell.Application")
    
    Dim folderPath As String
    
    folderPath = ""
    
    On Error Resume Next
    
    Dim selectedFolder As Object
    
    Set selectedFolder = shellApp.BrowseForFolder(0, prompt, 0, "")
    
    If (Not selectedFolder Is Nothing) Then
        folderPath = selectedFolder.Items.Item.Path
    End If
    
    Set shellApp = Nothing
    
    BrowseForFolder = folderPath
End Function