Untitled
unknown
plain_text
6 months ago
3.2 kB
3
Indexable
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
Editor is loading...
Leave a Comment