VBA Code to Split Excel Sheet into multiple workbooks grouped by value in the first column

[benjie1982]

Hi, I have some large spreadsheets of over 100k rows with a single sheet. Total number of columns varies

The first row is the header row, the first column contains a primary key ID.

I'm looking for a VBA code to split the data into separate workbooks (not sheets) grouped by the values in the first column.

e.g.

Id	Column 1	Column 2	Column 3	Column 4	Column 5
ID1	28​	16​		Home	A
ID1	185​	22​		Home	B
ID2	48​	48​		Business	C
ID3	8​	6​		Business	D

In the example i would end up with 3 workbooks called ID1, ID2 and ID3.
ID1 will have header row + the 2nd and 3rd rows having the value ID1.
ID2 will have header row + the 4th row having the value ID2
ID3 will have header row + the 5th row having the value ID3

If someone can help me out it would be very much appreciated. Thanks so much in advance.

 

[NdNoviceHlp]

Hi benjie1982. My limited testing seems to work OK. HTH. Dave
ps. Call Test to trial. The input sheet is sheet1 and will have to be adjusted to suit.

Dim Ar() As Variant, MaxCol As Integer, Cnt2 As Integer
Sub InputArray(InputStr As Variant)
Dim Rng As Range, Cnt As Integer, sht As Worksheet
Dim LC As Integer, Rowcnt As Integer, LR As Integer
Cnt = 0 'dimension array
Cnt2 = 0 'array position
MaxCol = 1
'load array
ReDim Preserve Ar(Cnt)
With ThisWorkbook.Sheets("Sheet1")
LR = .Cells(Rows.Count, 1).End(xlUp).Row
For Rowcnt = 1 To LR
If Sheets("Sheet1").Range("A" & Rowcnt) = InputStr Then
Cnt = Cnt + 1
ReDim Preserve Ar(Cnt)
LC = .Cells(Rowcnt, Columns.Count).End(xlToLeft).Column
If LC > MaxCol Then
MaxCol = LC
End If
Set Rng = .Range(.Cells(Rowcnt, 1), .Cells(Rowcnt, LC))
Ar(Cnt2) = Rng
Cnt2 = Cnt2 + 1
End If
Next Rowcnt
End With
End Sub

Sub OutputArray(wb As Workbook)
Dim LC As Integer, Cnt3 As Integer, R As Range
'output array
For Cnt3 = 0 To Cnt2 - 1
With wb.Sheets("sheet1")
.Range("A" & Cnt3 + 1).Resize(1, MaxCol) = Ar(Cnt3)
'remove N/A re. varied columns in array
LC = .Cells(Cnt3 + 1, .Columns.Count).End(xlToLeft).Column
For Each R In .Range(.Cells(Cnt3 + 1, 1), .Cells(Cnt3 + 1, LC))
If Application.WorksheetFunction.IsNA(R.Value) Then
R.Value = vbNullString
End If
Next R
End With
Next Cnt3
Erase Ar
End Sub

Sub test()
Dim Cnt As Integer, Cnt1 As Integer, Cnter As Integer
Dim Lastrow As Integer, NameArr() As Variant, NewBook As Workbook
On Error GoTo erfix
Application.ScreenUpdating = False
Application.DisplayAlerts = False
With Sheets("Sheet1")
    Lastrow = .Range("A" & .Rows.Count).End(xlUp).Row
'sort unique
For Cnt = 1 To Lastrow
For Cnt1 = 1 To (Cnt - 1)
If .Range("A" & Cnt1).Value = .Range("A" & Cnt).Value Then ' more than one entry
GoTo Bart
End If
Next Cnt1
Cnter = Cnter + 1
ReDim Preserve NameArr(Cnter)
NameArr(Cnter - 1) = .Range("A" & Cnt).Value
Bart:
Next Cnt
'loop unique
For Cnt = LBound(NameArr) To UBound(NameArr) - 1
Call InputArray(NameArr(Cnt))
Set NewBook = Workbooks.Add
With NewBook
Call OutputArray(NewBook)
.SaveAs Filename:=ThisWorkbook.Path & "\" & NameArr(Cnt) & ".xlsx", FileFormat:=51
.Close
End With
Next Cnt
End With
erfix:
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

 

[benjie1982]

Thanks so much! It works. Just one thing, it is only outputting the row without the header row. Is it possible to include the header row as well?

 

[Zot]

Here is another way you can achieve that. I hope I understood your request right

Sub SplitToWorkbook()

Dim strName As String
Dim key As Variant
Dim cell As Range, rngID As Range
Dim wbData As Workbook, wb As Workbook
Dim wsData As Worksheet, ws As Worksheet
Dim dictID As Object

Application.ScreenUpdating = False

Set dictID = CreateObject("Scripting.Dictionary")
Set wbData = ActiveWorkbook
Set wsData = wbData.Sheets("Data")                            ' Assuming sheet name is Data. Change accordingly.

Set rngID = wsData.Range("A2", Cells(wsData.Rows.Count, "A").End(xlUp))
' Collect all unique ID numbers in rngID
For Each cell In rngID
    If Not dictID.Exists(cell.Value) Then dictID.Add cell.Value, Nothing
Next

' Create workbook for each unique ID and create Header
For Each key In dictID
    Set wb = NewWorkbook(wbData.Path & "\", "WB " & key, 1)
    wsData.Range("A1", "F1").Copy ActiveSheet.Range("A1")
'    wb.Save
Next

' Transfer data to corresponding workbook
For Each cell In rngID
    Set wb = Workbooks("WB " & cell.Value & ".xlsx")
    Set ws = wb.Sheets("Sheet1")
    wsData.Range("A" & cell.Row, "F" & cell.Row).Copy ws.Cells(ws.Rows.Count, "A").End(xlUp).Offset(1)
Next

End Sub

Function NewWorkbook(wbPath As String, wbName As String, wsCount As Long) As Workbook
' creates a new workbook with wsCount (1 to 255) worksheets
Dim OriginalWorksheetCount&
Dim NewName$

Set NewWorkbook = Nothing
If wsCount < 1 Or wsCount > 255 Then Exit Function
OriginalWorksheetCount = Application.SheetsInNewWorkbook
Application.SheetsInNewWorkbook = wsCount
Set NewWorkbook = Workbooks.Add
NewName = wbPath & wbName
ActiveWorkbook.SaveAs NewName
Application.SheetsInNewWorkbook = OriginalWorksheetCount

End Function

 

[NdNoviceHlp]

Hi again benjie. You did ask for the headers. I forgot. This amended code seems to work. Dave

Dim Ar() As Variant, MaxCol As Integer, Cnt2 As Integer
Sub InputArray(InputStr As Variant)
Dim Rng As Range, Cnt As Integer, sht As Worksheet
Dim LC As Integer, Rowcnt As Integer, LR As Integer
Cnt = 0 'dimension array
Cnt2 = 0 'array position
MaxCol = 1
'load array
ReDim Preserve Ar(Cnt)
With ThisWorkbook.Sheets("Sheet1")
LR = .Cells(Rows.Count, 1).End(xlUp).Row
For Rowcnt = 2 To LR
If Sheets("Sheet1").Range("A" & Rowcnt) = InputStr Then
Cnt = Cnt + 1
ReDim Preserve Ar(Cnt)
LC = .Cells(Rowcnt, Columns.Count).End(xlToLeft).Column
If LC > MaxCol Then
MaxCol = LC
End If
Set Rng = .Range(.Cells(Rowcnt, 1), .Cells(Rowcnt, LC))
Ar(Cnt2) = Rng
Cnt2 = Cnt2 + 1
End If
Next Rowcnt
End With
End Sub

Sub OutputArray(wb As Workbook)
Dim LC As Integer, Cnt3 As Integer, R As Range
'output array
For Cnt3 = 0 To Cnt2 - 1
With wb.Sheets("Sheet1")
.Range("A" & Cnt3 + 2).Resize(1, MaxCol) = Ar(Cnt3)
'remove N/A re. varied columns in array
LC = .Cells(Cnt3 + 2, .Columns.Count).End(xlToLeft).Column
For Each R In .Range(.Cells(Cnt3 + 2, 1), .Cells(Cnt3 + 2, LC))
If Application.WorksheetFunction.IsNA(R.Value) Then
R.Value = vbNullString
End If
Next R
End With
Next Cnt3
Erase Ar
End Sub

Sub test()
Dim Cnt As Integer, Cnt1 As Integer, Cnter As Integer
Dim Lastrow As Integer, NameArr() As Variant, NewBook As Workbook
Dim LC As Integer, Arr2(1) As Variant
On Error GoTo erfix
Application.ScreenUpdating = False
Application.DisplayAlerts = False
With Sheets("Sheet1")
Lastrow = .Range("A" & .Rows.Count).End(xlUp).Row
LC = .Cells(1, Columns.Count).End(xlToLeft).Column
'header
Arr2(0) = .Range(.Cells(1, 1), .Cells(1, LC))
'sort unique
For Cnt = 2 To Lastrow
For Cnt1 = 2 To (Cnt - 1)
If .Range("A" & Cnt1).Value = .Range("A" & Cnt).Value Then ' more than one entry
GoTo Bart
End If
Next Cnt1
Cnter = Cnter + 1
ReDim Preserve NameArr(Cnter)
NameArr(Cnter - 1) = .Range("A" & Cnt).Value
Bart:
Next Cnt
'loop unique
For Cnt = LBound(NameArr) To UBound(NameArr) - 1
Call InputArray(NameArr(Cnt))
Set NewBook = Workbooks.Add
With NewBook
'header
.Sheets("sheet1").Range("A" & 1).Resize(1, LC) = Arr2(0)
Call OutputArray(NewBook)
.SaveAs Filename:=ThisWorkbook.Path & "\" & NameArr(Cnt) & ".xlsx", FileFormat:=51
.Close
End With
Next Cnt
End With
erfix:
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

 

[benjie1982]

Thank you all for your solutions they work nicely

 

[NdNoviceHlp]

You are welcome. Thanks for posting your outcome. Dave