Splitting Data into Workbooks - EDIT HELP

[horrellbt01]

Hello! I have found some code that gets me almost exactly what I am looking for (see below). The code essentially splits my table into multiple workbooks, splitting them based on what I select as the xVRg variant.

Everything works as it should. However, I would like to only copy over a specific column, or set of columns. How could I modify to allow this?

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 & "\" & "Storelist_" & 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

 

[horrellbt01]

Figured it out - Also modified it to allow the end-user to identify which column is copied.

Sub Custom_Store_List_Export()
    Dim lr As Long
    Dim ws As Worksheet
    Dim vcol As Integer, i As Integer
    Dim icol As Long
    Dim myarr As Variant
    Dim MDMID 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
    Dim uniqueValues As Collection
    Dim cell As Range
  
    On Error Resume Next
   
    ' Disable screen updating and calculations
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
   
    Set MDMID = Application.InputBox("Please select the MDM Store ID Column:", "", Type:=8)
    If TypeName(MDMID) = "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 = MDMID.Worksheet
    lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
    icol = ws.Columns.Count
    ws.Cells(1, icol) = "Unique"
  
    ' Collect unique values
    Set uniqueValues = New Collection
    On Error Resume Next
    For Each cell In ws.Range(ws.Cells(2, vcol), ws.Cells(lr, vcol))
        If cell.Value <> "" Then
            uniqueValues.Add cell.Value, CStr(cell.Value)
        End If
    Next cell
    On Error GoTo 0
  
    ' Prompt the user to select the folder to save the separated workbooks
    savePath = BrowseForFolder("Select a folder to save the separated workbooks")
  
    ' Create a new workbook for the header
    Set xWSTRg = Workbooks.Add
    MDMID.Rows(1).Copy
    xWSTRg.Sheets(1).Range("A1").PasteSpecial xlPasteAll
    xWSTRg.Close SaveChanges:=False
  
    ' Loop through unique values and create separate workbooks
    For i = 1 To uniqueValues.Count
        ws.Rows(1).AutoFilter field:=vcol, Criteria1:=uniqueValues(i)
        wbName = savePath & "\" & "Storelist_" & uniqueValues(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)
      
        MDMID.Rows(1).Copy
        xWS.Range("A1").PasteSpecial xlPasteAll
      
        ' Copy only the MDMID range instead of the full row
        MDMID.SpecialCells(xlCellTypeVisible).Copy xWS.Range("A1")
      
        xWS.Columns.AutoFit
      
        wb.Close SaveChanges:=True
    Next
  
    ws.AutoFilterMode = False
    ws.Activate
   
    ' Re-enable screen updating and calculations
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.DisplayAlerts = True
End Sub