Super User is a question and answer site for computer enthusiasts and power users. Join them; it only takes a minute:

Sign up
Here's how it works:
  1. Anybody can ask a question
  2. Anybody can answer
  3. The best answers are voted up and rise to the top

Is there a way in Excel to split a large file into a series of smaller ones, based on the contents of a single column?

eg: I have a file of sales data for all sales reps. I need to send them a file to make corrections and send back, but I dont want to send each of them the whole file (because I dont want them changing eachother's data). The file looks something like this:


RepName          Customer        ContactEmail
Adam             Cust1 
Adam             Cust2 
Bob              Cust3 

out of this I need:


RepName          Customer        ContactEmail
Adam             Cust1 
Adam             Cust2 

and salesdata_Bob.xls

Bob              Cust3 

Is there anything built-in to Excel 2007 to do this automatically, or should I break out the VBA?

share|improve this question
This do the work:… – Y. Shoham Sep 17 '13 at 20:30
up vote 5 down vote accepted

As far as I know there is nothing short of a macro that going to split you data and automatically save it onto a set of files for you. VBA is probably easier.

Update I implemented my suggestion. It loops through all the names defined in the named range 'RepList'. The named range is a dynamic named range of the form =OFFSET(Names!$A$2,0,0,COUNTA(Names!$A:$A)-1,1)

module follows.

Option Explicit

'Split sales data into separate columns baed on the names defined in
'a Sales Rep List on the 'Names' sheet.
Sub SplitSalesData()
    Dim wb As Workbook
    Dim p As Range

    Application.ScreenUpdating = False

    For Each p In Sheets("Names").Range("RepList")
        Set wb = ActiveWorkbook

        WritePersonToWorkbook wb, p.Value

        wb.SaveAs ThisWorkbook.Path & "\salesdata_" & p.Value
    Next p
    Application.ScreenUpdating = True
    Set wb = Nothing
End Sub

'Writes all the sales data rows belonging to a Person
'to the first sheet in the named SalesWB.
Sub WritePersonToWorkbook(ByVal SalesWB As Workbook, _
                          ByVal Person As String)
    Dim rw As Range
    Dim personRows As Range     'Stores all of the rows found
                                'containing Person in column 1
    For Each rw In UsedRange.Rows
        If Person = rw.Cells(1, 1) Then
            If personRows Is Nothing Then
                Set personRows = rw
                Set personRows = Union(personRows, rw)
            End If
        End If
    Next rw

    personRows.Copy SalesWB.Sheets(1).Cells(1, 1)
    Ser personRows = Nothing
End Sub

This workbook contains the code and the named range. The code is part of the 'Sales Data' sheet.

share|improve this answer
VBA it is... I'll post my code if/when it's done. – geofftnz Oct 19 '09 at 3:59
One thing thatr might make that task much easier is if you made a unique list of all the sales people and had that sitting in a separate column. That way you know how many files you have to handle upfront. If you have a lot of potential files, you can process the names one at a time. You might choose to just plow through it sequesntially, but I always like having options. – DaveParillo Oct 19 '09 at 4:08
It is only only letter (so I can't edit it for you) but I think penultimate line s/b Set not Ser. – pnuts Jan 17 '13 at 1:06
This is awesome, What modification in code would be required to have row headers for all different spreadsheets? – PSDebugger Nov 20 '15 at 20:11

For posterity, here's yet another macro to tackle this problem.

This macro will go through a specified column, top down, and split to a new file whenever a new value is encountered. Blanks or repeated values are kept together (as well as total rows), but your column values must be sorted or unique. I primarily designed it to work with PivotTables layout (once converted to values).

So as it is, there's no need to modify the code or prepare a named range. The macro starts by prompting the user for the column to process, as well as the row number at which to start - that is to skip the headers, and goes from there.

When a section is identified, rather than copying those values to another sheet, the entire worksheet is copied to a new workbook and all rows below and above the section are deleted. This allows to keep any printing setup, conditional formatting, charts or whatever else you might have in there, as well as keeping the header in each split file which is useful when distributing these files.

Files are saved in a \Split\ subfolder with the cell value as the filename. I have not yet extensively tested it on a variety of documents, but it works on my sample files. Feel free to try it out and let me know if you have issues.

The macro can be saved as an excel add-in (xlam) to add a button on the ribbon/quickaccess toolbar button for easy access.

Public Sub SplitToFiles()

' MACRO SplitToFiles
' Last update: 2012-03-04
' Author: mtone
' Version 1.1
' Description:
' Loops through a specified column, and split each distinct values into a separate file by making a copy and deleting rows below and above
' Note: Values in the column should be unique or sorted.
' The following cells are ignored when delimiting sections:
' - blank cells, or containing spaces only
' - same value repeated
' - cells containing "total"
' Files are saved in a "Split" subfolder from the location of the source workbook, and named after the section name.

Dim osh As Worksheet ' Original sheet
Dim iRow As Long ' Cursors
Dim iCol As Long
Dim iFirstRow As Long ' Constant
Dim iTotalRows As Long ' Constant
Dim iStartRow As Long ' Section delimiters
Dim iStopRow As Long
Dim sSectionName As String ' Section name (and filename)
Dim rCell As Range ' current cell
Dim owb As Workbook ' Original workbook
Dim sFilePath As String ' Constant
Dim iCount As Integer ' # of documents created

iCol = Application.InputBox("Enter the column number used for splitting", "Select column", 2, , , , , 1)
iRow = Application.InputBox("Enter the starting row number (to skip header)", "Select row", 5, , , , , 1)
iFirstRow = iRow

Set osh = Application.ActiveSheet
Set owb = Application.ActiveWorkbook
iTotalRows = osh.UsedRange.Rows.Count
sFilePath = Application.ActiveWorkbook.Path

If Dir(sFilePath + "\Split", vbDirectory) = "" Then
    MkDir sFilePath + "\Split"
End If

'Turn Off Screen Updating  Events
Application.EnableEvents = False
Application.ScreenUpdating = False

    ' Get cell at cursor
    Set rCell = osh.Cells(iRow, iCol)
    sCell = Replace(rCell.Text, " ", "")

    If sCell = "" Or (rCell.Text = sSectionName And iStartRow <> 0) Or InStr(1, rCell.Text, "total", vbTextCompare) <> 0 Then
        ' Skip condition met
        ' Found new section
        If iStartRow = 0 Then
            ' StartRow delimiter not set, meaning beginning a new section
            sSectionName = rCell.Text
            iStartRow = iRow
            ' StartRow delimiter set, meaning we reached the end of a section
            iStopRow = iRow - 1

            ' Pass variables to a separate sub to create and save the new worksheet
            CopySheet osh, iFirstRow, iStartRow, iStopRow, iTotalRows, sFilePath, sSectionName, owb.fileFormat
            iCount = iCount + 1

            ' Reset section delimiters
            iStartRow = 0
            iStopRow = 0

            ' Ready to continue loop
            iRow = iRow - 1
        End If
    End If

    ' Continue until last row is reached
    If iRow < iTotalRows Then
            iRow = iRow + 1
        ' Finished. Save the last section
        iStopRow = iRow
        CopySheet osh, iFirstRow, iStartRow, iStopRow, iTotalRows, sFilePath, sSectionName, owb.fileFormat
        iCount = iCount + 1

        ' Exit
        Exit Do
    End If

'Turn On Screen Updating  Events
Application.ScreenUpdating = True
Application.EnableEvents = True

MsgBox Str(iCount) + " documents saved in " + sFilePath

End Sub

Public Sub DeleteRows(targetSheet As Worksheet, RowFrom As Long, RowTo As Long)

Dim rngRange As Range
Set rngRange = Range(targetSheet.Cells(RowFrom, 1), targetSheet.Cells(RowTo, 1)).EntireRow

End Sub

Public Sub CopySheet(osh As Worksheet, iFirstRow As Long, iStartRow As Long, iStopRow As Long, iTotalRows As Long, sFilePath As String, sSectionName As String, fileFormat As XlFileFormat)
     Dim ash As Worksheet ' Copied sheet
     Dim awb As Workbook ' New workbook

     ' Copy book
     Set ash = Application.ActiveSheet

     ' Delete Rows after section
     If iTotalRows > iStopRow Then
         DeleteRows ash, iStopRow + 1, iTotalRows
     End If

     ' Delete Rows before section
     If iStartRow > iFirstRow Then
         DeleteRows ash, iFirstRow, iStartRow - 1
     End If

     ' Select left-topmost cell
     ash.Cells(1, 1).Select

     ' Clean up a few characters to prevent invalid filename
     sSectionName = Replace(sSectionName, "/", " ")
     sSectionName = Replace(sSectionName, "\", " ")
     sSectionName = Replace(sSectionName, ":", " ")
     sSectionName = Replace(sSectionName, "=", " ")
     sSectionName = Replace(sSectionName, "*", " ")
     sSectionName = Replace(sSectionName, ".", " ")
     sSectionName = Replace(sSectionName, "?", " ")

     ' Save in same format as original workbook
     ash.SaveAs sFilePath + "\Split\" + sSectionName, fileFormat

     ' Close
     Set awb = ash.Parent
     awb.Close SaveChanges:=False
End Sub
share|improve this answer

If someone else answers with the correct way of doing this that is quick, please ignore this answer.

I personally find myself using Excel and then spending a lot of time (somtimes hours) looking for a complicated way to do something or an over the top equation that will do everything when I will never use it again... and it turns out that if I just sat down and got on with the task manually it would take a fraction of the time.

If you only have a handful of people, what I recommend you do is simply highlight all the data, go to the data tab and click the sort button.

alt text

You can then choose what column to sort by, in your case you want to use Repname, then just copy and paste to individual files.

I am sure that using VBA or other tools, you may come up with a solution but the fact is, you will be looking at hours upon hours of work when just getting on with it by using the above method should get you done in next to no time.

Also, I think you can do this sort of thing on sharepoint + excel services, but that is a way over the top solution for this sort of thing.

share|improve this answer
This might be a good solution if you only have to do this one or twice, but often these sorts of grunt business tasks are the kinds of things that have to be done every week (or whatever) with depressing regularity. Even with a relatively few number of steps, I would favor automation. – DaveParillo Oct 19 '09 at 4:10
"hours upon hours of work" - sounds like a challenge. :) – geofftnz Oct 19 '09 at 19:24
lol - Well, I never aid it wasn't possible, I am always finding myself doing things like this - I was just trying to say that it would be quicker to do it manually... but obviously not as much fun! – William Hilsum Oct 19 '09 at 20:37

OK, so here's the first cut of the VBA. You call it like this:

SplitIntoFiles Range("A1:N1"), Range("A2:N2"), Range("B2"), "Split File - "

Where A1:N1 is your header row(s), A2:N2 is the first row of your data, B2 is the first cell in your pre-sorted key column. The last argument is the filename prefix. The key will be appended to this before saving.

Disclaimer: this code is nasty.

Option Explicit
Public Sub SplitIntoFiles(headerRange As Range, startRange As Range, keyCell As Range, filenameBase As String)

    ' assume the keyCell column is already sorted

    ' start a new workbook
    Dim wb As Workbook
    Dim ws As Worksheet

    Set wb = Application.Workbooks.Add
    Set ws = wb.ActiveSheet

    Dim destRange As Range
    Set destRange = ws.Range("A1")

    ' copy header
    headerRange.Copy destRange
    Set destRange = destRange.Offset(headerRange.Rows.Count)

    Dim keyValue As Variant
    keyValue = ""

    While keyCell.Value <> ""

        ' if we've got a new key, save the file and start a new one
        If (keyValue <> keyCell.Value) Then
        If keyValue <> "" Then
            'TODO: remove non-filename chars from keyValue
            wb.SaveAs filenameBase & CStr(keyValue)
            wb.Close False
            Set wb = Application.Workbooks.Add
            Set ws = wb.ActiveSheet
            Set destRange = ws.Range("A1")

            ' copy header
            headerRange.Copy destRange
            Set destRange = destRange.Offset(headerRange.Rows.Count)

            End If
        End If

        keyValue = keyCell.Value

        ' copy the contents of this row to the new sheet
        startRange.Copy destRange

        Set keyCell = keyCell.Offset(1)
        Set destRange = destRange.Offset(1)
        Set startRange = startRange.Offset(1)

    ' save residual
    'TODO: remove non-filename chars from keyValue
    wb.SaveAs filenameBase & CStr(keyValue)

End Sub
share|improve this answer
I updated my answer with a possible solution. It does depend on an externally defined named range to hold the unique definitions of your sales force, but that eliminates quite a bit of the complexity in your example. – DaveParillo Oct 22 '09 at 20:46

I sort by name and paste the information straight into a second Excel sheet, the one you want to send out. Excel pastes only the lines you see, not also the hidden rows. I also protect all cells except for the cells I want them to update. lol.

share|improve this answer
why lol ? no wonder you got 2 negative votes – CyprUS Nov 10 '15 at 1:55

You must log in to answer this question.

protected by Community Feb 27 '13 at 20:34

Thank you for your interest in this question. Because it has attracted low-quality or spam answers that had to be removed, posting an answer now requires 10 reputation on this site (the association bonus does not count).

Would you like to answer one of these unanswered questions instead?

Not the answer you're looking for? Browse other questions tagged .