Skip to content
Home » VBA Macro: Split Excel Worksheet into Multiple Worksheets Based on Column Value

VBA Macro: Split Excel Worksheet into Multiple Worksheets Based on Column Value

    Do you need to split data, currently held in a single worksheet, across multiple worksheets – based on a column value?  The code below will do this for you.  Please watch the video above to see how the VBA macro works.

    You can download the featured file here.

    Sub SplitData()

Dim SplitFld As Range 'the column the end user will select to base the split on
Dim Hdgs As Range 'the headings needed on each worksheet
Dim SplitItem As Range 'the current value in the column that has been selected
Dim NewWs As Worksheet 'a new worksheet as required
Dim ws As Worksheet 'worksheets in the current workbook
Dim WsExists As Boolean 'TRUE or FALSE: does a worksheet already exist for the SplitItem?
Dim SplitWs As Worksheet 'The active worksheet

Set SplitWs = ActiveSheet

On Error GoTo SplitFldError 'if the user cancels the SplitFld inputbox exit sub
'ask user to select the column to base the split on and store that range in the SplitFld variable
Set SplitFld = Application.InputBox _
(Prompt:="Select the column you want to split your data by (***do not include the column heading***)", _
Title:="Column", Type:=8)

On Error GoTo HdgsError 'if the user cancels the Hdgs inputbox exit sub
'ask the user to select the column headings and store that range in the Hdgs variable
Set Hdgs = Application.InputBox _
(Prompt:="Select the headings you want to appear on each worksheet", _
Title:="Headings", Type:=8)


Application.ScreenUpdating = False 'turning off screen updating makes the code run faster

For Each SplitItem In SplitFld 'for each value in the column the user has selected
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name = SplitItem Then 'check whether a worksheet already exists for that value
            WsExists = True ' and store TRUE or FALSE in the WsExists variable
            Exit For
        Else
            WsExists = False
        End If
    Next ws
    
    
    If WsExists Then 'if WsExists = TRUE, (if the worksheet does already exist)
    
        'copy the record to the next available row in that worksheet
        Range(SplitItem.End(xlToLeft), SplitItem.End(xlToLeft).End(xlToRight)).Copy _
        Destination:=Worksheets(SplitItem.Value).Range("A1").End(xlDown).Offset(1, 0)
    
        Else 'if WsExists = 'FALSE (if a worksheet doesn't yet exist)
        
        'Create a new worksheet and place it to the right of other worksheets in the workbook
        Set NewWs = Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
        'Name the worksheet using the current value stored in the SplitItem variable
        NewWs.Name = SplitItem
        
        'Copy the headings to the new worksheet
        Hdgs.Copy Destination:=NewWs.Range("A1")
        
        'Copy the record to the new worksheet
        Range(SplitItem.End(xlToLeft), SplitItem.End(xlToLeft).End(xlToRight)).Copy Destination:=NewWs.Range("A2")
        
    End If

Next SplitItem


For Each ws In ThisWorkbook.Worksheets 'autofit columns in each worksheet

    ws.UsedRange.Columns.AutoFit

Next ws

'turn screen updating back on
Application.ScreenUpdating = True

Exit Sub

SplitFldError:
Exit Sub

HdgsError:
Exit Sub
    
End Sub