Sign up ×
Super User is a question and answer site for computer enthusiasts and power users. It's 100% free, no registration required.

I know there are similar questions out there but I don't think they are quite the same.

I have an excel spreadsheet with the following headings-

First name -- Surname -- Host Trust -- Contact details -- etc -- etc

It is a large spreadsheet. I have to send an email every week to host trusts to inform them of who will be working with them and it is a nightmare dividing this up manually.

Is it possible to create a macro which will split this spreadsheet into several spreadsheets using the the data from the Host Trust column as the title of each spreadsheet?

share|improve this question
Sure, use the macro recorded to see how it's done. One easy way might be to filter your data on one specific Host Trust. Then copy all of that. Then paste it in the next sheet (although copy and paste isn't very efficient if you had to do hundreds of these). Check the code the macro recorded made and make a few copies of it and edit them separately to see how to get it to work. –  Graphth Jun 1 '12 at 17:35
Do you have the code you are using that saves them to seperate workbooks? –  user179341 Dec 10 '12 at 18:00

1 Answer 1

up vote 1 down vote accepted

Not knowing what version of Excel you are using, I can not guarantee this will work. It does what you ask (I tested it), buy filtering on column C, creates a tab for each unique record, then copies those rows to the new sheet. You will need to modify the code toward the top so it matches the range of your data.

BEFORE YOU DO ANYTHING; make a copy of your file as a backup.

If you are familiar with VBA, Alt + F11 will open the VBA window, you can copy this code directly. Once saved, it will appear in the macro list for you to run.

To give credit where credit is due, I found this at Excel Forum.

Sub Copy_To_Worksheets()
'Note: This macro use the function LastRow
    Dim My_Range As Range
    Dim FieldNum As Long
    Dim CalcMode As Long
    Dim ViewMode As Long
    Dim ws2 As Worksheet
    Dim Lrow As Long
    Dim cell As Range
    Dim CCount As Long
    Dim WSNew As Worksheet
    Dim ErrNum As Long

    'Set filter range on ActiveSheet: A1 is the top left cell of your filter range
    'and the header of the first column, D is the last column in the filter range.
    'You can also add the sheet name to the code like this :
    'Worksheets("Sheet1").Range("A1:D" & LastRow(Worksheets("Sheet1")))
    'No need that the sheet is active then when you run the macro when you use this.
    Set My_Range = Range("A1:O2000") '  & LastRow(ActiveSheet))

    If ActiveWorkbook.ProtectStructure = True Or _
       My_Range.Parent.ProtectContents = True Then
        MsgBox "Sorry, not working when the workbook or worksheet is protected", _
               vbOKOnly, "Copy to new worksheet"
        Exit Sub
    End If

    'This example filters on the first column in the range(change the field if needed)
    'In this case the range starts in A so Field:=1 is column A, 2 = column B, ......
    FieldNum = 3 ' I changed this to 3 for column C

    'Turn off AutoFilter
    My_Range.Parent.AutoFilterMode = False

    'Change ScreenUpdating, Calculation, EnableEvents, ....
    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    ViewMode = ActiveWindow.View
    ActiveWindow.View = xlNormalView
    ActiveSheet.DisplayPageBreaks = False

    'Add a worksheet to copy the a unique list and add the CriteriaRange
    Set ws2 = Worksheets.Add

    With ws2
        'first we copy the Unique data from the filter field to ws2
        My_Range.Columns(FieldNum).AdvancedFilter _
                Action:=xlFilterCopy, _
                CopyToRange:=.Range("A1"), Unique:=True

        'loop through the unique list in ws2 and filter/copy to a new sheet
        Lrow = .Cells(Rows.Count, "A").End(xlUp).Row
        For Each cell In .Range("A2:A" & Lrow)

            'Filter the range
            My_Range.AutoFilter Field:=FieldNum, Criteria1:="=" & _
             Replace(Replace(Replace(cell.Value, "~", "~~"), "*", "~*"), "?", "~?")

            'Check if there are no more then 8192 areas(limit of areas)
            CCount = 0
            On Error Resume Next
            CCount = My_Range.Columns(1).SpecialCells(xlCellTypeVisible) _
            On Error GoTo 0
            If CCount = 0 Then
                MsgBox "There are more than 8192 areas for the value : " & cell.Value _
                     & vbNewLine & "It is not possible to copy the visible data." _
                     & vbNewLine & "Tip: Sort your data before you use this macro.", _
                       vbOKOnly, "Split in worksheets"
                'Add a new worksheet
                Set WSNew = Worksheets.Add(After:=Sheets(Sheets.Count))
                On Error Resume Next
                WSNew.Name = cell.Value
                If Err.Number > 0 Then
                    ErrNum = ErrNum + 1
                    WSNew.Name = "Error_" & Format(ErrNum, "0000")
                End If
                On Error GoTo 0

                'Copy the visible data to the new worksheet
                With WSNew.Range("A1")
                    ' Paste:=8 will copy the columnwidth in Excel 2000 and higher
                    ' Remove this line if you use Excel 97
                    .PasteSpecial Paste:=8
                    .PasteSpecial xlPasteValues
                    .PasteSpecial xlPasteFormats
                    Application.CutCopyMode = False
                End With
            End If

            'Show all data in the range
            My_Range.AutoFilter Field:=FieldNum

        Next cell

        'Delete the ws2 sheet
        On Error Resume Next
        Application.DisplayAlerts = False
        Application.DisplayAlerts = True
        On Error GoTo 0

    End With

    'Turn off AutoFilter
    My_Range.Parent.AutoFilterMode = False

    If ErrNum > 0 Then
        MsgBox "Rename every WorkSheet name that start with ""Error_"" manually" _
             & vbNewLine & "There are characters in the name that are not allowed" _
             & vbNewLine & "in a sheet name or the worksheet already exist."
    End If

    'Restore ScreenUpdating, Calculation, EnableEvents, ....
    ActiveWindow.View = ViewMode
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = CalcMode
    End With

    MsgBox ("Copy Complete - - Remember to save your work.")

End Sub
share|improve this answer
HiThank you very much for your reply. in have used macros befor ebut took me about 3 weeks to eventually suss it out so i am a newby when it comes to this. Maybe my question should of been a buiit more precise. i am using excel 2010. the actually collum i need my data to be sorted by is located in Column F. Also do i have to set an output folder? or do i have to manually save each one? Apologies if i am being a bit 'Dim'! –  Sean Chadwick Jun 6 '12 at 12:26
You are welcome. In this code, you will need to change the column it uses to filter (line 31). Column F would be the sixth column, so change the 3 to a 6. When you asked about creating sheets, I thought you meant within the workbook. This code creates new sheets within the workbook for each unique field in the column sorted by. So if there are 13 Host Trusts, there will be 13 tabs. If you want it to create a new file for each one, that is different. –  CharlieRB Jun 6 '12 at 12:56
Please ignore my previous comment as i have found another macro to save to seperate work books. my only problkem now is qwhen i run this it splits half of my data fine but half of them are saved under the name Error 1, Error 2 etc. any ideas why? –  Sean Chadwick Jun 6 '12 at 13:08
Sorry. I do not know what the code you are using is doing to be able to know why it is doing that. –  CharlieRB Jun 6 '12 at 13:19
Apologies im probably confusing things now. i have used the code that you have provided above however when i run the macro 10 of the 20 records are saving under the name outputerror_0001. do you have any ideas why? Thanks for your help by the way –  Sean Chadwick Jun 6 '12 at 13:30

Your Answer


By posting your answer, you agree to the privacy policy and terms of service.

Not the answer you're looking for? Browse other questions tagged or ask your own question.