Split Excel Sheet Into Multiple Files Based On Column Using VBA

Do you have a big data on excel sheet and you need to distribute that sheet in multiple sheets, based on some data in a column? This very basic task but time consuming.
006
For example, I have this data. This data has a column named Date, Writer and Title. Writer column has name of writer of respective title. I want to get each writer’s data in separate sheets.
007
To do this manually, I have to do the following:

  1. Filter one name
  2. Copy the filtered data
  3. Add a sheet
  4. Paste the data
  5. Rename the sheet
  6. Repeat all above 5 steps for each.

In this example, I have only three names. Imagine if have 100s of names. How would you split data into different sheets? It will take a lot of time and it will drain you too.
To Automate above process of splitting sheet into multiple sheets, follow these steps.

  • Press Alt+F11. This will open VB Editor for Excel
  • Add A new Module
  • Copy Below Code in Module.
'***--------------------Main Sub-------------------------***
Sub SplitIntoSheets()With Application
.ScreenUpdating = False
.DisplayAlerts = False
End WithThisWorkbook.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

'***---------------Gets Unique Names-----------------------***
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

‘***------------Creates Sheets-----------------------------***
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
End Sub

When you’ll run SplitIntoSheets() procedure, the sheet will be divided into multiple sheets, based on given column. You can add button on sheet and assign this macro to it.

How It Works
The above code has two procedures and one function. Two procedures are SplitIntoSheets(), CreateSheets(uniques As Range, clmNo As Long) and one function is RemoveDuplicates(uniques As Range) As Range.

First Procedure is SplitIntoSheets(). This is the main procedure. This procedure sets the variables and RemoveDuplicates to get unique names from given column and then passes those names to CreateSheets for creating sheets.

RemoveDuplicates takes one argument that is range which contains name. Removes duplicates from them and returns a range object that contains unique names.

Now CreateSheets is called. It takes two arguments. First the unique names and second the column no. from which we it will fitler data. Now CreateSheets takes each name from uniques and filters the given column number by each name. Copies the filtered data, adds a sheet and paste the data there. And your data is split into different sheet in seconds.

You can download the file here.
Split Into Sheets

How to use the file:

    • Copy your data on Sheet1. Make sure it starts from A1.

008

    • Click on Button Split Into Sheets
    • Input the column letter from which you want to split. Click Ok.

009

    • You’ll see a prompt like this. Your sheet is splitted.

0011
0013
I hope article about splitting data into separate sheets was helpful for you. If you have any doubts about this or about any other feature of excel, feel free to ask it in comments section below.

 

Click the below link to download the working file:

Leave a Reply

Your email address will not be published. Required fields are marked *

You may use these HTML tags and attributes: <a href="" title=""> <abbr title=""> <acronym title=""> <b> <blockquote cite=""> <cite> <code> <del datetime=""> <em> <i> <q cite=""> <strike> <strong>

Terms and Conditions of use

The applications/code on this site are distributed as is and without warranties or liability. In no event shall the owner of the copyrights, or the authors of the applications/code be liable for any loss of profit, any problems or any damage resulting from the use or evaluation of the applications/code.

Visit Us On TwitterVisit Us On FacebookVisit Us On Google PlusVisit Us On Youtube