Sometimes we need to split excel sheet based on column data. Here is an easy way using VBA code:
- Open Excel File and then open Visual Basic for Application by pressing ALT+F11 Key.
- Now go to insert menu and open Module.
- Copy Code (In end of page) and paste to Module.
- Now Click on Run button. This will ask for column name give yours Eg: A,C,AB.
- Wait for a while and all new extracted sheets will be there.
VBA Code:
Sub SplitIntoSheets()
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
ThisWorkbook.Activate
Sheet1.Activate
'clearing filter if any
On Error Resume Next
Sheet1.ShowAllData
On Error GoTo 0
Dim lsrClm As Long
Dim lstRow As Long
'counting last used row
lstRow = Cells(Rows.Count, 1).End(xlUp).Row
Dim uniques As Range
Dim clm As String, clmNo As Long
On Error GoTo handler
clm = Application.InputBox("From which column you want create files" & vbCrLf & "E.g. A,B,C,AB,ZA etc.")
clmNo = Range(clm & "1").Column
Set uniques = Range(clm & "2:" & clm & lstRow)
'Calling Remove Duplicates to Get Unique Names
Set uniques = RemoveDuplicates(uniques)
Call CreateSheets(uniques, clmNo)
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.AlertBeforeOverwriting = True
.Calculation = xlCalculationAutomatic
End With
Sheet1.Activate
MsgBox "Well Done!"
Exit Sub
Data.ShowAllData
handler:
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.AlertBeforeOverwriting = True
.Calculation = xlCalculationAutomatic
End With
End Sub
Function RemoveDuplicates(uniques As Range) As Range
ThisWorkbook.Activate
Sheets.Add
On Error Resume Next
ActiveSheet.Name = "uniques"
Sheets("uniques").Activate
On Error GoTo 0
uniques.Copy
Cells(2, 1).Activate
ActiveCell.PasteSpecial xlPasteValues
Range("A1").Value = "uniques"
Dim lstRow As Long
lstRow = Cells(Rows.Count, 1).End(xlUp).Row
Range("A2:A" & lstRow).Select
ActiveSheet.Range(Selection.Address).RemoveDuplicates Columns:=1, Header:=xlNo
lstRow = Cells(Rows.Count, 1).End(xlUp).Row
Set RemoveDuplicates = Range("A2:A" & lstRow)
End Function
Sub CreateSheets(uniques As Range, clmNo As Long)
Dim lstClm As Long
Dim lstRow As Long
For Each unique In uniques
Sheet1.Activate
lstRow = Cells(Rows.Count, 1).End(xlUp).Row
lstClm = Cells(1, Columns.Count).End(xlToLeft).Column
Dim dataSet As Range
Set dataSet = Range(Cells(1, 1), Cells(lstRow, lstClm))
dataSet.AutoFilter field:=clmNo, Criteria1:=unique.Value
lstRow = Cells(Rows.Count, 1).End(xlUp).Row
lstClm = Cells(1, Columns.Count).End(xlToLeft).Column
Debug.Print lstRow; lstClm
Set dataSet = Range(Cells(1, 1), Cells(lstRow, lstClm))
dataSet.Copy
Sheets.Add
ActiveSheet.Name = unique.Value2
ActiveCell.PasteSpecial xlPasteAll
Next unique
MsgBox ThisWorkbook.Sheets.Count
End Sub
