Take the 2-minute tour ×
Super User is a question and answer site for computer enthusiasts and power users. It's 100% free, no registration required.

I have a problem in splitting a spreadsheet according to a given column (names), and saving new files for each name.

I am using the code posted by mtone here: Can I split a spreadsheet into multiple files based on a column in Excel 2007?

 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

Do
    ' 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
    Else
        ' Found new section
        If iStartRow = 0 Then
            ' StartRow delimiter not set, meaning beginning a new section
            sSectionName = rCell.Text
            iStartRow = iRow
        Else
            ' 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  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

I have a sheet with 40 names, based on which I would like to create 40 separate sheets. Unfortunately I get a 400 error.

For testing purposes, I've deleted 39 names, leaving just one unique record - here the script works just fine, it saves the list for one person to a separate file.

Do you have any advice?

share|improve this question
    
Thank you for you quick reply. After debugging the code line by line, it stops at: Set rngRange = Range(targetSheet.Cells(RowFrom, 1), targetSheet.Cells(RowTo, 1)).EntireRow Returning the error: Run-time error'1004': Application-defined or object-defined error After googling this error, it seems that it's a rather generic one, could be caused by many factors? –  Lukasz P. Nov 29 '12 at 9:47
    
The code I'm using can be found in this answer: superuser.com/questions/57157/… This line of code is included in it indeed. –  Lukasz P. Nov 29 '12 at 11:13
    
To be honest I cannot figure out where the code I posted here came from. I am using the code as posted in SU57157. Jerry Beaucaire's solution does not really do the job in my case. In the meantime I am still trying to get the code from SU57157 to work, no luck so far though. –  Lukasz P. Dec 3 '12 at 14:23
add comment

Your Answer

 
discard

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

Browse other questions tagged or ask your own question.