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

I have a Worksheet which I want to split to separate workbooks for each ProjectNumber. and I want the .xlsb files for each to be save with projectnumber and the original file name.

the projectnumber column is Column P

I would like an .xlsb file for each with only the records for projectNumber 1#####, projectnumber 1#####, and so on.

What VBA code would I use to do this?

Similarly in reverse

i would like another code to be able to combine all of these saved seperate workbooks and merge them all into one worksheet as it was in the first place.


https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA

https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA


https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=Ugxq4JHRza_zx3sz0fx4AaABAg
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgzMCQUIQgrbec400jl4AaABAg
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgwhVTFaD469mW9wO194AaABAg. 9gJzxwFcnPU9gORqKw5tW_
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=Ugyb8nmKKoXvcdM58gV4AaABAg
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgwvvXcl1oa79xS7BAV4AaABAg
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgxvIFArksPprylHXYZ4AaABAg
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=Ugxq4JHRza_zx3sz0fx4AaABAg
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA

https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA
https://eileenslounge.com/viewtopic.php?p=316705#p316705
https://eileenslounge.com/viewtopic.php?p=316704#p316704
https://eileenslounge.com/viewtopic.php?f=27&t=40919&p=316597#p316597
https://eileenslounge.com/viewtopic.php?p=316412#p316412
https://eileenslounge.com/viewtopic.php?p=316254#p316254
https://eileenslounge.com/viewtopic.php?p=316280#p316280
https://eileenslounge.com/viewtopic.php?p=315915#p315915
https://eileenslounge.com/viewtopic.php?p=315512#p315512
https://eileenslounge.com/viewtopic.php?p=315744#p315744
https://www.eileenslounge.com/viewtopic.php?p=315512#p315512
https://eileenslounge.com/viewtopic.php?p=315680#p315680
https://eileenslounge.com/viewtopic.php?p=315743#p315743
https://www.eileenslounge.com/viewtopic.php?p=315326#p315326
https://www.eileenslounge.com/viewtopic.php?f=30&t=40752
https://eileenslounge.com/viewtopic.php?p=314950#p314950
https://www.eileenslounge.com/viewtopic.php?p=314940#p314940
https://www.eileenslounge.com/viewtopic.php?p=314926#p314926
https://www.eileenslounge.com/viewtopic.php?p=314920#p314920
https://www.eileenslounge.com/viewtopic.php?f=30&t=40533&p=314837#p314837
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA

[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

---

https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA
https://eileenslounge.com/viewtopic.php?p=326972#p326972
https://eileenslounge.com/viewtopic.php?p=326853#p326853
https://eileenslounge.com/viewtopic.php?p=326446#p326446
https://eileenslounge.com/viewtopic.php?f=27&t=41986
https://eileenslounge.com/viewtopic.php?p=325610#p325610
https://eileenslounge.com/viewtopic.php?p=325609#p325609
https://eileenslounge.com/viewtopic.php?p=325605#p325605
https://eileenslounge.com/viewtopic.php?p=325548#p325548
https://eileenslounge.com/viewtopic.php?p=316441#p316441
https://eileenslounge.com/viewtopic.php?p=324736#p324736
https://eileenslounge.com/viewtopic.php?p=324990#p324990
https://eileenslounge.com/viewtopic.php?f=27&t=41937&p=325485#p325485
https://eileenslounge.com/viewtopic.php?p=325609#p325609
https://eileenslounge.com/viewtopic.php?p=325610#p325610
https://www.youtube.com/watch?v=3t8Mk4URi6g&lc=UgzoakhRXOsCaoRm_Nd4AaABAg. 8xzeMdC8IOGADdPM65i9PG
https://www.youtube.com/watch?v=3t8Mk4URi6g&lc=UgzoakhRXOsCaoRm_Nd4AaABAg. 8xzeMdC8IOGADdPQHFk_zm
http://www.eileenslounge.com/viewtopic.php?p=324457#p324457
http://www.eileenslounge.com/viewtopic.php?p=324064#p324064
http://www.eileenslounge.com/viewtopic.php?p=323960#p323960
https://www.youtube.com/watch?v=7VwD9KuyMk4&lc=UgyZCnNfnZRfgwzDlQF4AaABAg
https://www.youtube.com/watch?v=7VwD9KuyMk4&lc=UgyZCnNfnZRfgwzDlQF4AaABAg. ADd4m2zp_xDADd6Nnotj1C
s://www.youtube.com/watch?v=7VwD9KuyMk4&lc=UgySdtXqcaA27wQLd1t4AaABAg
http://www.eileenslounge.com/viewtopic.php?p=323959#p323959
http://www.eileenslounge.com/viewtopic.php?f=30&t=41784
http://www.eileenslounge.com/viewtopic.php?p=323966#p323966
http://www.eileenslounge.com/viewtopic.php?p=323959#p323959
http://www.eileenslounge.com/viewtopic.php?p=323960#p323960
http://www.eileenslounge.com/viewtopic.php?p=323894#p323894
http://www.eileenslounge.com/viewtopic.php?p=323843#p323843
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA

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

---

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

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

---

Attachment 780
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

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

I get 43 xlsb files as output

Attachment 781
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

---

Quote:

---

Originally Posted by Excel Fox

I get 43 xlsb files as output

---

what version excel r u using?

i found the problem. it is becuase the source workbook file format is .xlsb and once i changed it to .xls then it worked.

all of my source workbooks are originally xlsb is there anyway that the code will work in xlsb source workbook?

i also checked with other file formats it does not work in xlsm as well. it only works in .xls seems like the code only functions in old version of excel only.

IT's working fine for me in the binary format (xlsb).

I've made a small modification. try this

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 .Parent.UsedRange.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

---

i use excel 2010

https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA
https://eileenslounge.com/viewtopic.php?p=326972#p326972
https://eileenslounge.com/viewtopic.php?p=326853#p326853
https://eileenslounge.com/viewtopic.php?p=326446#p326446
https://eileenslounge.com/viewtopic.php?f=27&t=41986
https://eileenslounge.com/viewtopic.php?p=325610#p325610
https://eileenslounge.com/viewtopic.php?p=325609#p325609
https://eileenslounge.com/viewtopic.php?p=325605#p325605
https://eileenslounge.com/viewtopic.php?p=325548#p325548
https://eileenslounge.com/viewtopic.php?p=316441#p316441
https://eileenslounge.com/viewtopic.php?p=324736#p324736
https://eileenslounge.com/viewtopic.php?p=324990#p324990
https://eileenslounge.com/viewtopic.php?f=27&t=41937&p=325485#p325485
https://eileenslounge.com/viewtopic.php?p=325609#p325609
https://eileenslounge.com/viewtopic.php?p=325610#p325610
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA

It's more to do with your available system resources, than anything else I think. Can you try the same macro on a more powerful computer?

the modified code you provided, worked perfectly.

now only one issue that all the generated workbooks have the default worksheet name as "sheet1" i want the worksheet name to be the same as the source worksheet which is "GL_Details" for all those generated workbooks the worksheet name should be "GL_Details"

can you please help on this part of the code?

Quote:

---

Originally Posted by Excel Fox

It's more to do with your available system resources, than anything else I think. Can you try the same macro on a more powerful computer?

---

The reason why the modified code worked is because I reduced the range of cells to just the used range of the sheet. So it's your available resources that's cause the trouble. Having said that, I should have only used the used range instead of the entire cells.

To add a name to the sheet, just add the below line, right after the workbook is added

Code:

---

wb.Sheets(1).Name = "NameOfSheetHere"

---

thank you very much. i do not even know your name. but i i guess that our messages have crossed before in mrexcel forums.

so, please give pm me your paypal ID so that i send you 10 bucks.

also looking forward for solution to my outlook project in the other thread.

Quote:

---

Originally Posted by Excel Fox

The reason why the modified code worked is because I reduced the range of cells to just the used range of the sheet. So it's your available resources that's cause the trouble. Having said that, I should have only used the used range instead of the entire cells.

To add a name to the sheet, just add the below line, right after the workbook is added

Code:

---

wb.Sheets(1).Name = "NameOfSheetHere"

---

---

https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA

https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA