Bdtyktl

I found some code which works perfectly to separate a file based on a column (line 31) into separate tabs within a worksheet.

I just need it to separate the files based on a column into a separate workbook, and also prompt to add a suffix to identify each file.

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))

My_Range.Parent.Select



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 = 6 ' 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) _

                 .Areas(1).Cells.Count

        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"

        Else

            '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")

                Err.Clear

            End If

            On Error GoTo 0



            'Copy the visible data to the new worksheet

            My_Range.SpecialCells(xlCellTypeVisible).Copy

            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

                .Select

            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

    .Delete

    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, ....

My_Range.Parent.Select

ActiveWindow.View = ViewMode

With Application

    .ScreenUpdating = True

    .EnableEvents = True

    .Calculation = CalcMode

End With



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





End Sub

Any ideas on how to modify this?

Here's a macro I did a few months ago at work. Maybe it can be of help. If not, you could always look at how I create workbooks in the CopySheet() Sub and adapt your current macro.

User action: The macro prompts you for the column number (C=3) to divide by, and which row to start at (typically the first row below headers). This macro does not prompt for a suffix - instead it automatically name workbooks with the column value and saves them in a Split subfolder.

Requirement: This requires your table to be sorted by your primary column.

Context: I made it primarily to split large PivotTables (first converted to values with another macro) on the first row label in layout mode. Since those tables have many blank cells which are just hidden duplicates, it doesn't rely on filters and instead goes from top to bottom - hence the sorted requirement.

Method: Whenever a new value is encountered in the specified column, it copies the entire original worksheet to a new book each time, then deletes all rows before and after that current section (variables iFirstRow, iStartRow, iStopRow, iTotalRows are used to keep track of those chunks). This keeps any formatting, page setups, formulas, etc. you may have in your original book.

Public Sub SplitToFiles()



' MACRO SplitToFiles

' Last update: 2012-03-05

'

' 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 < iTotalRows Then

            iRow = iRow + 1

    Else

        ' 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

Loop



'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

rngRange.Select

rngRange.Delete



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

     osh.Copy

     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