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

[jamilm]

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/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=Ugxq4JHRza_zx3sz0fx4AaABAg)
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgzMCQUIQgrbec400jl4AaABAg (https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgzMCQUIQgrbec400jl4AaABAg)
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgwhVTFaD469mW9wO194AaABAg.9gJzxwFcnPU9gORqKw5t W_ (https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgwhVTFaD469mW9wO194AaABAg.9gJzxwFcnPU9gORqKw5t W_)
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=Ugyb8nmKKoXvcdM58gV4AaABAg (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=UgwvvXcl1oa79xS7BAV4AaABAg)
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgxvIFArksPprylHXYZ4AaABAg (https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgxvIFArksPprylHXYZ4AaABAg)
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=Ugxq4JHRza_zx3sz0fx4AaABAg (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://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=316705#p316705)
https://eileenslounge.com/viewtopic.php?p=316704#p316704 (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?f=27&t=40919&p=316597#p316597)
https://eileenslounge.com/viewtopic.php?p=316412#p316412 (https://eileenslounge.com/viewtopic.php?p=316412#p316412)
https://eileenslounge.com/viewtopic.php?p=316254#p316254 (https://eileenslounge.com/viewtopic.php?p=316254#p316254)
https://eileenslounge.com/viewtopic.php?p=316280#p316280 (https://eileenslounge.com/viewtopic.php?p=316280#p316280)
https://eileenslounge.com/viewtopic.php?p=315915#p315915 (https://eileenslounge.com/viewtopic.php?p=315915#p315915)
https://eileenslounge.com/viewtopic.php?p=315512#p315512 (https://eileenslounge.com/viewtopic.php?p=315512#p315512)
https://eileenslounge.com/viewtopic.php?p=315744#p315744 (https://eileenslounge.com/viewtopic.php?p=315744#p315744)
https://www.eileenslounge.com/viewtopic.php?p=315512#p315512 (https://www.eileenslounge.com/viewtopic.php?p=315512#p315512)
https://eileenslounge.com/viewtopic.php?p=315680#p315680 (https://eileenslounge.com/viewtopic.php?p=315680#p315680)
https://eileenslounge.com/viewtopic.php?p=315743#p315743 (https://eileenslounge.com/viewtopic.php?p=315743#p315743)
https://www.eileenslounge.com/viewtopic.php?p=315326#p315326 (https://www.eileenslounge.com/viewtopic.php?p=315326#p315326)
https://www.eileenslounge.com/viewtopic.php?f=30&t=40752 (https://www.eileenslounge.com/viewtopic.php?f=30&t=40752)
https://eileenslounge.com/viewtopic.php?p=314950#p314950 (https://eileenslounge.com/viewtopic.php?p=314950#p314950)
https://www.eileenslounge.com/viewtopic.php?p=314940#p314940 (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=314926#p314926)
https://www.eileenslounge.com/viewtopic.php?p=314920#p314920 (https://www.eileenslounge.com/viewtopic.php?p=314920#p314920)
https://www.eileenslounge.com/viewtopic.php?f=30&t=40533&p=314837#p314837 (https://www.eileenslounge.com/viewtopic.php?f=30&t=40533&p=314837#p314837)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)

[jamilm]

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]

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


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]

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

[Excel Fox]

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


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]

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

[Excel Fox]

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

[Excel Fox]

I get 43 xlsb files as output

[jamilm]

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?





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


I get 43 xlsb files as output

[Excel Fox]

what version excel r u using?

[jamilm]

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?

[jamilm]

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.

[Excel Fox]

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

I've made a small modification. try this




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

[jamilm]

i use excel 2010

[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?

[jamilm]

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?


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?

[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



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

[jamilm]

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.



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



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


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/channel/UCnxwq2aGJRbjOo_MO54oaHA)