Split Data Into Seprate Sheets By Criteria

**tigeravatar** · 11-14-2012, 03:32 PM

Hello all,

I've seen this question come up a few times, "How do I split data from a master sheet into separate sheets?"
I created a macro that is a bit generic so that users can adapt it to their needs.
Here is the macro code:

Sub SplitDataIntoSheetsByCriteria()
'Macro created by TigerAvatar at www.excelforum.com, November 2012
'Purpose is to split the data of a sheet into separate sheets based on a key column

    'Declare constants
    'Adjust these to suit your specific needs
    Const strDataSheet As String = "Sheet1"     'The name of the sheet that contains the data
    Const strCriteriaCol As String = "A"        'The letter of the column that will be evaluated
    Const lHeaderRow As Long = 1                'The number of the Header Row
    
    'Declare variables
    Dim ws As Worksheet             'Used to loop through the worksheets in order to alphabetize them
    Dim wsData As Worksheet         'Used to store the Data Sheet to a worksheet object variable
    Dim rngCriteria As Range        'Used to store the Range on the Data Sheet that will be evaluated
    Dim CriteriaCell As Range       'Used to loop through rngCriteria
    Dim lCalc As XlCalculation      'Used to store the current calculation state of the workbook
    Dim strNameWS As String         'Used to create legal worksheet names
    Dim i As Long                   'Generic looping variable
    
    'Set the wsData and rngCriteria variables using the constants declared at the top of this macro
    Set wsData = Sheets(strDataSheet)
    Set rngCriteria = wsData.Range(strCriteriaCol & lHeaderRow, wsData.Cells(Rows.Count, strCriteriaCol).End(xlUp))
    
    'Store the current calculation state, set calculation to manual, disable events, alerts, and screenupdating
    'This allows the code to run faster and prevents "screen flickering"
    With Application
        lCalc = .Calculation
        .Calculation = xlCalculationManual
        .EnableEvents = False
        .DisplayAlerts = False
        .ScreenUpdating = False
    End With
    
    'Assume code will fail and provide an error handler
    On Error GoTo CleanExit
    
    'Loop through each cell in rngCriteria
    For Each CriteriaCell In rngCriteria.Cells
        'Make sure the cell is after the Header Row
        If CriteriaCell.Row > lHeaderRow Then
            'Make sure the cell is not blank
            If Len(CriteriaCell.Text) > 0 Then
                
                'Generate a legal worksheet name
                strNameWS = CriteriaCell.Text
                For i = 1 To 7
                    strNameWS = Replace(strNameWS, Mid(":\/?*[]", i, 1), " ")
                Next i
                strNameWS = Left(WorksheetFunction.Trim(strNameWS), 31)
                
                'Check if there is already a sheet with the same name
                If Not Evaluate("IsRef(" & strNameWS & "!A1)") Then
                    'Need to create a new sheet
                    'Add the new sheet, name it appropriately, copy over the information based on the criteria
                    With Sheets.Add(After:=Sheets(Sheets.Count))
                        .Name = strNameWS
                        wsData.Rows(lHeaderRow).EntireRow.Copy .Range("A1")
                        rngCriteria.AutoFilter 1, CriteriaCell.Text
                        rngCriteria.Offset(1).EntireRow.Copy .Range("A2")
                    End With
                End If
            End If
        End If
    Next CriteriaCell
    
    'Alphabetize the worksheets
    For Each ws In ActiveWorkbook.Sheets
        For i = 1 To ActiveWorkbook.Sheets.Count
            If ws.Name < Sheets(i).Name Then ws.Move Before:=Sheets(i)
        Next i
    Next ws
    
    'Set the Data sheet to be the first sheet in the workbook and select that sheet so it is displayed after macro completes
    wsData.Move Before:=Sheets(1)
    wsData.Select
    
'If there were any errors, the code immediately goes here
'The code will also exit here even if there are no errors
CleanExit:
    
    'Remove any remaining filters
    rngCriteria.AutoFilter
    
    'Set calculation back to what it was, re-enable events, alerts, and screenupdating
    With Application
        .Calculation = lCalc
        .EnableEvents = True
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
    
    'Display the error that occurred (if any) and clear the error
    If Err.Number <> 0 Then
        MsgBox Err.Description, , "Error: " & Err.Number
        Err.Clear
    End If
    
    'Object variable cleanup
    Set ws = Nothing
    Set wsData = Nothing
    Set rngCriteria = Nothing
    Set CriteriaCell = Nothing
    
End Sub

How to use a macro:

Make a copy of the workbook the macro will be run on
- Always run new code on a workbook copy, just in case the code doesn't run smoothly
- This is especially true of any code that deletes anything
In the copied workbook, press ALT+F11 to open the Visual Basic Editor
Insert | Module
Copy the provided code and paste into the module
Close the Visual Basic Editor
In Excel, press ALT+F8 to bring up the list of available macros to run
Double-click the desired macro (I named this one SplitDataIntoSheetsByCriteria)

**tigeravatar** · 11-14-2012, 03:58 PM

It was suggested to me that the code could be made to prompt the user to select the criteria column at run-time instead of using constants at the top of the code. Here is a version that prompts the user:

Sub SplitDataIntoSheetsByCriteria_v2()
'Macro created by TigerAvatar at www.excelforum.com, November 2012
'Purpose is to split the data of a sheet into separate sheets based on a key column
'This is version 2, which implements a prompt to have the user select the criteria column

    'Declare constants
    'Adjust these to suit your specific needs
    Const lHeaderRow As Long = 1                'The number of the Header Row
    
    'Declare variables
    Dim ws As Worksheet             'Used to loop through the worksheets in order to alphabetize them
    Dim wsData As Worksheet         'Used to store the Data Sheet to a worksheet object variable
    Dim rngSelection As Range       'Used to store the selection chosen when the user is prompted to select the criteria column
    Dim rngCriteria As Range        'Used to store the Range on the Data Sheet that will be evaluated
    Dim CriteriaCell As Range       'Used to loop through rngCriteria
    Dim lCalc As XlCalculation      'Used to store the current calculation state of the workbook
    Dim strNameWS As String         'Used to create legal worksheet names
    Dim i As Long                   'Generic looping variable
    
    'Prompt user to select the criteria column
    On Error Resume Next                        'Prevents error if user pressed cancel
    Set rngSelection = Application.InputBox("Select the criteria column that will be evaluated", "Criteria Column Selection", Selection.Address, Type:=8)
    On Error GoTo 0                             'Removes the On Error Resume Next behavior
    If rngSelection Is Nothing Then Exit Sub    'User pressed cancel
    
    'Set the wsData and rngCriteria variables using the header row constant and the rngSelection that was chosen by the user
    Set wsData = rngSelection.Parent
    Set rngCriteria = Range(wsData.Cells(lHeaderRow, rngSelection.Column), wsData.Cells(Rows.Count, rngSelection.Column).End(xlUp))
    
    'Store the current calculation state, set calculation to manual, disable events, alerts, and screenupdating
    'This allows the code to run faster and prevents "screen flickering"
    With Application
        lCalc = .Calculation
        .Calculation = xlCalculationManual
        .EnableEvents = False
        .DisplayAlerts = False
        .ScreenUpdating = False
    End With
    
    'Assume code will fail and provide an error handler
    On Error GoTo CleanExit
    
    'Loop through each cell in rngCriteria
    For Each CriteriaCell In rngCriteria.Cells
        'Make sure the cell is after the Header Row
        If CriteriaCell.Row > lHeaderRow Then
            'Make sure the cell is not blank
            If Len(CriteriaCell.Text) > 0 Then
                
                'Generate a legal worksheet name
                strNameWS = CriteriaCell.Text
                For i = 1 To 7
                    strNameWS = Replace(strNameWS, Mid(":\/?*[]", i, 1), " ")
                Next i
                strNameWS = Left(WorksheetFunction.Trim(strNameWS), 31)
                
                'Check if there is already a sheet with the same name
                If Not Evaluate("IsRef(" & strNameWS & "!A1)") Then
                    'Need to create a new sheet
                    'Add the new sheet, name it appropriately, copy over the information based on the criteria
                    With Sheets.Add(After:=Sheets(Sheets.Count))
                        .Name = strNameWS
                        wsData.Rows(lHeaderRow).EntireRow.Copy .Range("A1")
                        rngCriteria.AutoFilter 1, CriteriaCell.Text
                        rngCriteria.Offset(1).EntireRow.Copy .Range("A2")
                    End With
                End If
            End If
        End If
    Next CriteriaCell
    
    'Alphabetize the worksheets
    For Each ws In ActiveWorkbook.Sheets
        For i = 1 To ActiveWorkbook.Sheets.Count
            If ws.Name < Sheets(i).Name Then ws.Move Before:=Sheets(i)
        Next i
    Next ws
    
    'Set the Data sheet to be the first sheet in the workbook and select that sheet so it is displayed after macro completes
    wsData.Move Before:=Sheets(1)
    wsData.Select
    
'If there were any errors, the code immediately goes here
'The code will also exit here even if there are no errors
CleanExit:
    
    'Remove any remaining filters
    rngCriteria.AutoFilter
    
    'Set calculation back to what it was, re-enable events, alerts, and screenupdating
    With Application
        .Calculation = lCalc
        .EnableEvents = True
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
    
    'Display the error that occurred (if any) and clear the error
    If Err.Number <> 0 Then
        MsgBox Err.Description, , "Error: " & Err.Number
        Err.Clear
    End If
    
    'Object variable cleanup
    Set ws = Nothing
    Set wsData = Nothing
    Set rngSelection = Nothing
    Set rngCriteria = Nothing
    Set CriteriaCell = Nothing
    
End Sub

Credit to the suggestion goes to jeffreybrown, thanks Jeff!

**robi0342** · 03-23-2016, 09:18 PM

Is it possible, to run multiple macro's at the same time. So different criteria columns go to different tabs?

Thanks!
C

**tigeravatar** · 12-31-2012, 12:13 PM

I received this Private Message from dfulmer:

Originally Posted by dfulmer

Hi tigeravatar,

I have been trying to figure out a way to split data into separate sheets based on one criteria all day and then was given a link to your macro. It initially works great - everything sorted fine. However, my main sheet of data will constantly be updated and/or edited and when I re-ran the macro, it didn't move any updates that were made.

Any thoughts?

I looked over the code and realized that if the sheet name already exists, then it does not actually move the data to the existing sheet. This 3rd version addresses that issue:

Sub SplitDataIntoSheetsByCriteria_v3()
'Macro created by TigerAvatar at www.excelforum.com, November 2012
'Purpose is to split the data of a sheet into separate sheets based on a key column
'This is version 3, which fixes a bug encountered when a sheet name already exists

    'Declare constants
    'Adjust these to suit your specific needs
    Const lHeaderRow As Long = 1                'The number of the Header Row
    
    'Declare variables
    Dim ws As Worksheet             'Used to loop through the worksheets in order to alphabetize them
    Dim wsData As Worksheet         'Used to store the Data Sheet to a worksheet object variable
    Dim wsDest As Worksheet         'Used to store the Destination Sheet to a worksheet object variable
    Dim rngSelection As Range       'Used to store the selection chosen when the user is prompted to select the criteria column
    Dim rngCriteria As Range        'Used to store the Range on the Data Sheet that will be evaluated
    Dim CriteriaCell As Range       'Used to loop through rngCriteria
    Dim lCalc As XlCalculation      'Used to store the current calculation state of the workbook
    Dim strNameWS As String         'Used to create legal worksheet names
    Dim strHistory As String        'Used to keep a criteria history so that multiple items do not get copied over
    Dim i As Long                   'Generic looping variable
    
    'Prompt user to select the criteria column
    On Error Resume Next                        'Prevents error if user pressed cancel
    Set rngSelection = Application.InputBox("Select the criteria column that will be evaluated", "Criteria Column Selection", Selection.Address, Type:=8)
    On Error GoTo 0                             'Removes the On Error Resume Next behavior
    If rngSelection Is Nothing Then Exit Sub    'User pressed cancel
    
    'Set the wsData and rngCriteria variables using the header row constant and the rngSelection that was chosen by the user
    Set wsData = rngSelection.Parent
    Set rngCriteria = Range(wsData.Cells(lHeaderRow, rngSelection.Column), wsData.Cells(Rows.Count, rngSelection.Column).End(xlUp))
    
    'Store the current calculation state, set calculation to manual, disable events, alerts, and screenupdating
    'This allows the code to run faster and prevents "screen flickering"
    With Application
        lCalc = .Calculation
        .Calculation = xlCalculationManual
        .EnableEvents = False
        .DisplayAlerts = False
        .ScreenUpdating = False
    End With
    
    'Assume code will fail and provide an error handler
    On Error GoTo CleanExit
    
    'Loop through each cell in rngCriteria
    For Each CriteriaCell In rngCriteria.Cells
        'Make sure the cell is after the Header Row
        If CriteriaCell.Row > lHeaderRow Then
            'Make sure the cell is not blank
            If Len(CriteriaCell.Text) > 0 Then
                
                'Check if the text in this cell has not been encountered yet
                If InStr(1, "||" & strHistory & "||", "||" & CriteriaCell.Text & "||", vbTextCompare) = 0 Then
                    'The text in this cell has not been encountered yet, add it to the history list and proceed with data split
                    strHistory = strHistory & "||" & CriteriaCell.Text
                    
                    'Generate a legal worksheet name
                    strNameWS = CriteriaCell.Text
                    For i = 1 To 7
                        strNameWS = Replace(strNameWS, Mid(":\/?*[]", i, 1), " ")
                    Next i
                    strNameWS = Trim(Left(WorksheetFunction.Trim(strNameWS), 31))
                    
                    'Check if there is already a sheet with the same name
                    If Not Evaluate("IsRef(" & strNameWS & "!A1)") Then
                        'Need to create a new sheet
                        'Add the new sheet, name it appropriately, copy over the headers
                        Set wsDest = Sheets.Add(After:=Sheets(Sheets.Count))
                        With wsDest
                            .Name = strNameWS
                            wsData.Rows(lHeaderRow).EntireRow.Copy .Range("A1")
                        End With
                    Else
                        'Sheet already exists
                        Set wsDest = Sheets(strNameWS)
                    End If
                    
                    'The following line is used to clear existing data in the destination sheet to prevent duplicates
                    'Put an apostrophe in front of the line to comment it out so that it will not run if you do not need/want it to
                    wsDest.UsedRange.Offset(1).ClearContents
                    
                    'Copy over the data
                    rngCriteria.AutoFilter 1, CriteriaCell.Text
                    rngCriteria.Offset(1).EntireRow.Copy wsDest.Cells(Rows.Count, "A").End(xlUp).Offset(1)
                End If
            End If
        End If
    Next CriteriaCell
    
    'Alphabetize the worksheets
    For Each ws In ActiveWorkbook.Sheets
        For i = 1 To ActiveWorkbook.Sheets.Count
            If ws.Name < Sheets(i).Name Then ws.Move Before:=Sheets(i)
        Next i
    Next ws
    
    'Set the Data sheet to be the first sheet in the workbook and select that sheet so it is displayed after macro completes
    wsData.Move Before:=Sheets(1)
    wsData.Select
    
'If there were any errors, the code immediately goes here
'The code will also exit here even if there are no errors
CleanExit:
    
    'Remove any remaining filters
    rngCriteria.AutoFilter
    
    'Set calculation back to what it was, re-enable events, alerts, and screenupdating
    With Application
        .Calculation = lCalc
        .EnableEvents = True
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
    
    'Display the error that occurred (if any) and clear the error
    If Err.Number <> 0 Then
        MsgBox Err.Description, , "Error: " & Err.Number
        Err.Clear
    End If
    
    'Object variable cleanup
    Set ws = Nothing
    Set wsData = Nothing
    Set wsDest = Nothing
    Set rngSelection = Nothing
    Set rngCriteria = Nothing
    Set CriteriaCell = Nothing
    
End Sub

Thank you for pointing that, dfulmer!