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

benjie1982

New Member
Joined
Apr 12, 2017
Messages
9
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.
IdColumn 1Column 2Column 3Column 4Column 5
ID1
28​
16​
HomeA
ID1
185​
22​
HomeB
ID2
48​
48​
BusinessC
ID3
8​
6​
BusinessD

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.
 

Excel Facts

Create a chart in one keystroke
Select the data and press Alt+F1 to insert a default chart. You can change the default chart to any chart type

NdNoviceHlp

Well-known Member
Joined
Nov 9, 2002
Messages
3,187
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.
Code:
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

New Member
Joined
Apr 12, 2017
Messages
9
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

Well-known Member
Joined
Nov 26, 2020
Messages
2,236
Office Version
  1. 2016
Platform
  1. Windows
Here is another way you can achieve that. I hope I understood your request right :)

VBA Code:
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

Well-known Member
Joined
Nov 9, 2002
Messages
3,187
Hi again benjie. You did ask for the headers. I forgot. This amended code seems to work. Dave
Code:
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
 
Solution

Forum statistics

Threads
1,181,944
Messages
5,932,904
Members
436,869
Latest member
ABGTH

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top