10$ For VBA Code Split Data To Multiple Workbook Based On Unique Values In A Column

**jamilm** · 05-22-2013, 05:40 PM

**jamilm** · 05-22-2013, 05:53 PM

[CODE]file is uploaded here https://skydrive.live.com/redir?resid=D7C00A2BF29043E0!257

for the spliting part code. i have found the following code from search and it somehow does not work. perhaps needs some

Code:

Sub SplitWorkbook(Optional colLetter As String, Optional SavePath As String)
If colLetter = "" Then colLetter = "P"
Dim lastValue As String
Dim hasHeader As Boolean
Dim wb As Workbook
Dim c As Range
Dim currentRow As Long
hasHeader = True 'Indicate true or false depending on if sheet  has header row.

If SavePath = "" Then SavePath = ThisWorkbook.Path
'Sort the workbook.
ThisWorkbook.Worksheets(1).Sort.SortFields.Add Key:=Range(colLetter & ":" & colLetter), _
    SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ThisWorkbook.Worksheets(1).Sort
    .SetRange Cells
    If hasHeader Then ' Was a header indicated?
        .Header = xlYes
    Else
        .Header = xlNo
    End If
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With

For Each c In ThisWorkbook.Sheets(1).Range("P:P")
    If c.Value = "" Then Exit For
    If c.Row = 1 And hasHeader Then
    Else
        If lastValue <> c.Value Then
            If Not (wb Is Nothing) Then
                wb.SaveAs SavePath & "\" & lastValue & ".xlsb"
                wb.Close
            End If
            lastValue = c.Value
            currentRow = 1
            Set wb = Application.Workbooks.Add
        End If
        ThisWorkbook.Sheets(1).Rows(c.Row & ":" & c.Row).Copy
        wb.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Select
        wb.Sheets(1).Paste

    End If
Next
If Not (wb Is Nothing) Then
    wb.SaveAs SavePath & "\" & lastValue & ".xlsb"
    wb.Close
End If
End Sub

**jamilm** · 05-22-2013, 08:00 PM

i also worked out this code but it creates the workbooks but somehow some of the data is missing on those created workbooks

Code:

Sub DistributeRowsToNewWBS()
Dim wbNew As Workbook
Dim wsData As Worksheet
Dim wsCrit As Worksheet
Dim wsNew As Worksheet
Dim rngCrit As Range
Dim LastRow As Long
    
    Set wsData = Worksheets("Expenditure_Details") ' name of worksheet with the data
    Set wsCrit = Worksheets.Add
    
    LastRow = wsData.Range("A" & Rows.Count).End(xlUp).Row
    
    ' column H has the criteria
    wsData.Range("p1:p" & LastRow).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=wsCrit.Range("A1"), Unique:=True
    
    Set rngCrit = wsCrit.Range("A2")
    While rngCrit.Value <> ""
        Set wsNew = Worksheets.Add
        ' change E to reflect columns to copy
        wsData.Range("A1:bp" & LastRow).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=rngCrit.Offset(-1).Resize(2), CopyToRange:=wsNew.Range("A1"), Unique:=True
        wsNew.Name = rngCrit
        wsNew.Copy
        Set wbNew = ActiveWorkbook
        ' saves new workbook in path of existing workbook
        wbNew.SaveAs ThisWorkbook.Path & "\" & rngCrit
        wbNew.Close SaveChanges:=True
        Application.DisplayAlerts = False
        wsNew.Delete
        rngCrit.EntireRow.Delete
        Set rngCrit = wsCrit.Range("A2")
    Wend
    
    wsCrit.Delete
    Application.DisplayAlerts = True
    
End Sub

**jamilm** · 05-22-2013, 08:00 PM

please let me know if this is possible, otherwise, please delete the thread. thanks.

**Excel Fox** · 05-22-2013, 08:27 PM

Here's the code. Run this from within the source workbook

Code:

Sub SplitWorkbook()

    Dim colLetter As String, SavePath As String
    Dim lastValue As String
    Dim wb As Workbook
    Dim lng As Long
    Dim currentRow As Long
    colLetter = "P"
    SavePath = "" 'Indicate the path to save
    If SavePath = "" Then SavePath = ThisWorkbook.Path
    'Sort the workbook.
    With ThisWorkbook.Worksheets(1)
        .Sort.SortFields.Add Key:=.Range(colLetter & ":" & colLetter), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        With .Sort
            .SetRange Cells
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        For lng = 2 To .Range(colLetter & .Rows.Count).End(xlUp).Row
            If .Cells(lng, colLetter).Value = "" Then Exit For
            lastValue = .Cells(lng, colLetter).Value
            .Cells.AutoFilter field:=.Cells(lng, colLetter).Column, Criteria1:=lastValue
            lng = .Cells(.Rows.Count, colLetter).End(xlUp).Row
            Set wb = Application.Workbooks.Add(xlWorksheet)
            .Rows(1 & ":" & lng).Copy wb.Sheets(1).Cells(Rows.Count, 1).End(xlUp)
            wb.SaveAs SavePath & "\" & lastValue, 50
            wb.Close
        Next
        .AutoFilterMode = False
    End With
    
End Sub

**jamilm** · 05-22-2013, 10:15 PM

Capture.JPG
this code did not work. it gives two errors one. worksheet error

and also vba run time error 1004 debugger stops at with Sort .apply

**Excel Fox** · 05-22-2013, 10:29 PM

Works absolutely fine at my side. For the resources issue, try restarting your computer, and then run the code.

**Excel Fox** · 05-22-2013, 10:32 PM

I get 43 xlsb files as output

**jamilm** · 05-22-2013, 10:56 PM

Capture.JPG
i restarted and tried again. still get the same error. also the runtime error

do i need to add any reference from the object library?

Code:

Sub SplitWorkbook()

    Dim colLetter As String, SavePath As String
    Dim lastValue As String
    Dim wb As Workbook
    Dim lng As Long
    Dim currentRow As Long
    colLetter = "P"
    SavePath = "" 'Indicate the path to save
    If SavePath = "" Then SavePath = ThisWorkbook.Path
    'Sort the workbook.
    With ThisWorkbook.Worksheets(1)
        .Sort.SortFields.Add Key:=.Range(colLetter & ":" & colLetter), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        With .Sort
            .SetRange Cells
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        For lng = 2 To .Range(colLetter & .Rows.Count).End(xlUp).Row
            If .Cells(lng, colLetter).Value = "" Then Exit For
            lastValue = .Cells(lng, colLetter).Value
            .Cells.AutoFilter field:=.Cells(lng, colLetter).Column, Criteria1:=lastValue
            lng = .Cells(.Rows.Count, colLetter).End(xlUp).Row
            Set wb = Application.Workbooks.Add(xlWorksheet)
            .Rows(1 & ":" & lng).Copy wb.Sheets(1).Cells(Rows.Count, 1).End(xlUp)
            wb.SaveAs SavePath & "\" & lastValue, 50
            wb.Close
        Next
        .AutoFilterMode = False
    End With
    
End Sub