locked
Can I split a spreadsheet into multiple files based on a column RRS feed

  • Question

  • I am working on a huge spreadsheet that logs thousands of transactions
    from dozens of customers. I save daily report under following path C:\Users\shekar\Desktop\Testing\ daily Report.xls.

    File Name: Daily Report

    My report look like this:

    Client Reference  Fund Name   Client Name   Amount   E-mail Id
    123                       ABC               SAM              500         admin1@cus.com
    213                      CDF               ADAM             300         admin1@cus.com
    1243                   EFG                   ADAM             200        admin1@cus.com

    What I need to be able to do run a macro for File Name: Daily Report & split up
    up that spreadsheet by customer Client Name (column C) and save a file for
    every customer (along with the header) as a file named "(column C).xls" I want it to save every file in one pass, and
    each file should include every column from A through P for the rows
    included.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 dont want to send each of them the whole file . The file looks something like this:

    Client Reference  Fund Name   Client Name   Amount   E-mail Id
    123                       ABC               SAM              500         admin1@cus.com
    213                      CDF               ADAM             300         admin1@cus.com
    1243                   EFG                   ADAM             200        admin1@cus.com

    out of this I need:

    Run Macro based on Client Name & save file Name Daily report_Adam.xls

    Client Reference  Fund Name   Client Name   Amount   E-mail Id
    213                      CDF               ADAM             300         admin1@cus.com
    1243                  EFG                   ADAM             200        admin1@cus.com

    and Daily report_Sam.xls

    Client Reference  Fund Name   Client Name   Amount   E-mail Id
    123                       ABC               SAM              500         admin1@cus.com

    can some 1 Help..

    Thursday, August 9, 2012 12:56 PM

Answers

  • Sub ExportDatabaseToSeparateFiles()
    'Export is based on the value in the KeyCol
        Dim myCell As Range
        Dim mySht As Worksheet
        Dim myName As String
        Dim myArea As Range
        Dim myShtName As String
        Dim KeyCol As String
        Dim myField As Integer

        myShtName = ActiveSheet.Name
        KeyCol = "C"

        Set myArea = Intersect(ActiveSheet.UsedRange, Range(KeyCol & "1").EntireColumn).Cells

        Set myArea = myArea.Offset(1, 0).Resize(myArea.Rows.Count - 1, 1)
        myField = myArea.Column - myArea.CurrentRegion.Cells(1).Column + 1

        For Each myCell In myArea
            On Error GoTo NoSheet
            myName = Worksheets(myCell.Value).Name
            GoTo SheetExists:
    NoSheet:
            Set mySht = Worksheets.Add(Before:=Worksheets(1))
            mySht.Name = myCell.Value
            With myCell.CurrentRegion
                .AutoFilter Field:=myField, Criteria1:=myCell.Value
                .SpecialCells(xlCellTypeVisible).Copy _
                        mySht.Range("A1")
                mySht.Cells.EntireColumn.AutoFit
                .AutoFilter
            End With
            Resume
    SheetExists:
        Next myCell

        For Each mySht In ActiveWorkbook.Worksheets
            If mySht.Name = myShtName Then
                Exit Sub
            Else
                mySht.Move
                ActiveWorkbook.SaveAs ActiveSheet.Name & ".xls"
                ActiveWorkbook.Close
            End If
        Next mySht
    End Sub


    HTH, Bernie

    • Proposed as answer by CSharpNoob2011 Thursday, August 9, 2012 4:25 PM
    • Marked as answer by Quist Zhang Saturday, August 11, 2012 6:51 PM
    Thursday, August 9, 2012 4:20 PM
  • Hello C#:

    Bernie is always "Quick to the Draw"... but here is another way to do the same thing.  This is actually an application.  I will upload the application to my SkyDrive.

    You open the workbook, click the button, navigate to the "All Clients" workbook, and it creates all the separate workbooks.  It also sorts the data by client name to make sure they are in the proper order.

    There are many ways to solve the same issue :)

    Option Explicit
    ' ************************************************
    ' Variables For File Open Dialogue Box
    ' ************************************************
    Dim strDialogueFileTitle As String
    Dim strFilt As String
    Dim intFilterIndex As Integer
    Dim strCancel As String
    Dim strWorkbookNameAndPath As String
    ' **************************************************
    ' Workbook And Worksheet Variables
    ' **************************************************
    Dim wkbAllClientsWorkbook As Workbook
    Dim wksAllClientsWorksheet As Worksheet
    Dim wkbNewClientWorkbook As Workbook
    Dim wksNewClientWorksheet As Worksheet
    
    Public Sub CreateClientWorkbooks()
    ' **************************************************
    ' Range Variables
    ' **************************************************
    Dim rngRangeToSort As Range
    Dim rngRangeOfClientNames As Range
    Dim rngClientDataToSave As Range
    Dim C As Range
    
    ' **************************************************
    ' Other Variables
    ' **************************************************
    Dim strSingleClientWorkbookPath As String
    Dim lngStartingRowForClientWorksheet As Long
    Dim lngEndingRowForClientWorksheet As Long
    Dim strLastClientName As String
    Dim lngNumberOfLinesInAllClients As Long
    
    Application.ScreenUpdating = False
    
    ' **************************************************
    ' Initialize Variables
    ' **************************************************
    strSingleClientWorkbookPath = "C:\Users\shekar\Desktop\Testing\"
    
    ' ****************************************************************************
    ' Set Up Filters For Which Files Should Show In The Open File Dialog Box
    ' ****************************************************************************
    strFilt = "Excel Files (*.xls),*.xls," & _
              "CSV Files (*.xlsx),*.xlsx,"
    
    ' ****************************************************************************
    ' Set Up The Prompt In The Dialogue Box
    ' ****************************************************************************
    intFilterIndex = 1
    strDialogueFileTitle = "Select The Daily Report"
    
    ' ****************************************************************************
    ' Present the Open File Dialogue To The User
    ' ****************************************************************************
    Call OpenFileDialogue
    
    ' ****************************************************************************
    ' Notify The User If No File Was Successfully Opened
    ' ****************************************************************************
    If strCancel = "Y" Then
        MsgBox ("An Open Error Occurred Importing Your File Selection")
        Exit Sub
    End If
    
    ' ********************************************************
    ' Set The Workbook and Worksheet Variables
    ' ********************************************************
    Set wkbAllClientsWorkbook = ActiveWorkbook
    Set wksAllClientsWorksheet = wkbAllClientsWorkbook.ActiveSheet
    
    ' ********************************************************
    ' Locate The Last Data Line In the "All Clients"
    ' ********************************************************
    lngNumberOfLinesInAllClients = wksAllClientsWorksheet.Cells(Rows.Count, "C").End(xlUp).Row
    
    ' ********************************************************
    ' Set The Sort Range - Assume 26 Columns of Data
    ' ********************************************************
    Set rngRangeToSort = Range(wksAllClientsWorksheet.Cells(2, 1), wksAllClientsWorksheet.Cells(lngNumberOfLinesInAllClients, 26))
    
    ' ********************************************************
    ' Sort The Worksheet By Client Name In Column A3
    ' ********************************************************
    rngRangeToSort.Sort Key1:=wksAllClientsWorksheet.Range("C2"), Order1:=xlAscending, _
                              Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
                              Orientation:=xlTopToBottom, _
                              DataOption1:=xlSortNormal
    
    ' *********************************************************
    ' Now That The Worksheet Is Sorted, Write Out New Workbooks
    ' For Each Unique Client Name
    ' *********************************************************
    Set rngRangeOfClientNames = Range(wksAllClientsWorksheet.Cells(2, 3), wksAllClientsWorksheet.Cells(lngNumberOfLinesInAllClients, 3))
    strLastClientName = wksAllClientsWorksheet.Cells(2, 3).Value
    lngStartingRowForClientWorksheet = 2
    
    For Each C In rngRangeOfClientNames
        If C.Value <> strLastClientName Then
            strLastClientName = C.Offset(-1, 0).Value
            lngEndingRowForClientWorksheet = C.Offset(-1, 0).Row
            Set rngClientDataToSave = Range(wksAllClientsWorksheet.Cells(lngStartingRowForClientWorksheet, 1), _
                                            wksAllClientsWorksheet.Cells(lngEndingRowForClientWorksheet, 26))
            Call AddNewClientWorkbook(strSingleClientWorkbookPath & strLastClientName & ".xls", rngClientDataToSave)
            lngStartingRowForClientWorksheet = C.Row
            strLastClientName = C.Value
        End If
    Next C
    ' *********************************************************
    ' Write Out Last Workbook
    ' *********************************************************
    strLastClientName = wksAllClientsWorksheet.Cells(lngNumberOfLinesInAllClients, 3).Value
    Set rngClientDataToSave = Range(wksAllClientsWorksheet.Cells(lngStartingRowForClientWorksheet, 1), _
                                    wksAllClientsWorksheet.Cells(lngNumberOfLinesInAllClients, 26))
    Call AddNewClientWorkbook(strSingleClientWorkbookPath & strLastClientName & ".xls", rngClientDataToSave)
    
    wkbAllClientsWorkbook.Close SaveChanges:=False
    
    Application.ScreenUpdating = True
    
    End Sub
    
    Private Sub OpenFileDialogue()
    
    ' ************************************************
    ' Display a File Open Dialogue Box For The User
    ' ************************************************
    strCancel = "N"
    strWorkbookNameAndPath = Application.GetOpenFilename _
        (FileFilter:=strFilt, _
         FilterIndex:=intFilterIndex, _
         Title:=strDialogueFileTitle)
       
    ' ************************************************
    ' Exit If No File Selected
    ' ************************************************
    If strWorkbookNameAndPath = "" Then
        MsgBox ("No Filename Selected")
        strCancel = "Y"
        Exit Sub
    ElseIf strWorkbookNameAndPath = "False" Then
        MsgBox ("You Clicked The Cancel Button")
        strCancel = "Y"
        Exit Sub
    End If
    
    ' ******************************************************
    ' Now That You Have The User Selected File Name, Open It
    ' ******************************************************
    Workbooks.Open strWorkbookNameAndPath
    
    End Sub
    
    Private Sub AddNewClientWorkbook(PathAndName As String, RangeOfOneClient As Range)
    ' ******************************************************
    ' This Creates A Workbook For A Unique Client
    ' ******************************************************
    Set wkbNewClientWorkbook = Workbooks.Add
    Set wksNewClientWorksheet = wkbNewClientWorkbook.Sheets(1)
    
    Range(wksAllClientsWorksheet.Cells(1, 1), wksAllClientsWorksheet.Cells(1, 26)).Copy wksNewClientWorksheet.Cells(1, 1)
    RangeOfOneClient.Copy wksNewClientWorksheet.Cells(2, 1)
    
    With wkbNewClientWorkbook
        .Title = "Client Sales"
        .Subject = "Sales"
        .SaveAs Filename:=PathAndName
    End With
    
    wkbNewClientWorkbook.Close
    
    End Sub
    

    Regards,


    Rich Locus, Logicwurks, LLC

    http://www.logicwurks.com

    • Proposed as answer by CSharpNoob2011 Thursday, August 9, 2012 6:10 PM
    • Marked as answer by Quist Zhang Saturday, August 11, 2012 6:51 PM
    Thursday, August 9, 2012 5:11 PM
  • Hi Bernie,

    Thanks for your reply here is my below code it working very fine

        ChDir "C:\Documents and Settings\dn91742\Desktop\Testing"
        Workbooks.Open Filename:= _
            "C:\Documents and Settings\dn91742\Desktop\Testing\81a.xls"
        Selection.AutoFilter
        ActiveSheet.Range("$A$1:$S$205").AutoFilter Field:=3, Criteria1:="=0005*", _
            Operator:=xlAnd
        Range("A1:S205").Select
        Selection.Copy
        Workbooks.Add
        ActiveSheet.Paste
        Application.CutCopyMode = False
        ChDir "C:\Documents and Settings\dn91742\Desktop\Testing\Output"
        ActiveWorkbook.SaveAs Filename:= _
            "C:\Documents and Settings\dn91742\Desktop\Testing\Output\0005.xlsx", FileFormat _
            :=xlOpenXMLWorkbook, CreateBackup:=False
        ActiveWindow.Close
        ActiveWindow.LargeScroll ToRight:=-2
        ActiveSheet.Range("$A$1:$S$205").AutoFilter Field:=3, Criteria1:="=0006*", _
            Operator:=xlAnd
        Cells.Select
        Selection.Copy
        Workbooks.Add
        ActiveSheet.Paste
        Application.CutCopyMode = False
        ActiveWorkbook.SaveAs Filename:= _
            "C:\Documents and Settings\dn91742\Desktop\Testing\Output\0006.xlsx", FileFormat _
            :=xlOpenXMLWorkbook, CreateBackup:=False
        ActiveWindow.Close
        ActiveSheet.Range("$A$1:$S$205").AutoFilter Field:=3, Criteria1:="=0007*", _
            Operator:=xlAnd
        Cells.Select
        Selection.Copy
        Workbooks.Add
        ActiveSheet.Paste
        Application.CutCopyMode = False
        ActiveWorkbook.SaveAs Filename:= _
            "C:\Documents and Settings\dn91742\Desktop\Testing\Output"\0007.xlsx", FileFormat _
            :=xlOpenXMLWorkbook, CreateBackup:=False
        ActiveWindow.Close
        ActiveSheet.Range("$A$1:$S$205").AutoFilter Field:=3, Criteria1:="=0008*", _
            Operator:=xlAnd
        Selection.Copy
        Workbooks.Add
        ActiveSheet.Paste
        Application.CutCopyMode = False
        ActiveWorkbook.SaveAs Filename:= _
            "C:\Documents and Settings\dn91742\Desktop\Testing\Output"\0008.xlsx", FileFormat _
            :=xlOpenXMLWorkbook, CreateBackup:=False
        ActiveWindow.Close
        ActiveSheet.Range("$A$1:$S$205").AutoFilter Field:=3, Criteria1:="=5123*", _
            Operator:=xlAnd
        Selection.Copy
        Workbooks.Add
        ActiveSheet.Paste
        Application.CutCopyMode = False
        ActiveWorkbook.SaveAs Filename:= _
            "C:\Documents and Settings\dn91742\Desktop\Testing\Output"\5123.xlsx", FileFormat _
            :=xlOpenXMLWorkbook, CreateBackup:=False
        ActiveWindow.Close
        ActiveSheet.Range("$A$1:$S$205").AutoFilter Field:=3, Criteria1:="=5134*", _
            Operator:=xlAnd
        Selection.Copy
        Workbooks.Add
        ActiveSheet.Paste
        Application.CutCopyMode = False
        ActiveWorkbook.SaveAs Filename:= _
            "C:\Documents and Settings\dn91742\Desktop\Testing\Output"\5134.xlsx", FileFormat _
            :=xlOpenXMLWorkbook, CreateBackup:=False
        ActiveWindow.Close

    End Sub.

    The above code is creating each file like 0005.xls,0006.xls,0007.xls,0008.xls,5123.xls,& 5134.xls based on filter.

    I want to filter multiple Criteria1:="=0005, Criteria2:="=0006,Criteria3:="=0007, Criteria4:="=0008,Criteria5:="=5123,Criteria5:="=5134 & save in

    ActiveWorkbook.SaveAs Filename:= _
            "C:\Documents and Settings\dn91742\Desktop\Testing\Output"\ABC.xlsx", FileFormat _
            :=xlOpenXMLWorkbook, CreateBackup:=False


    • Edited by adcz250 Thursday, August 9, 2012 6:14 PM
    • Marked as answer by Quist Zhang Saturday, August 11, 2012 6:51 PM
    Thursday, August 9, 2012 6:11 PM

All replies

  • Sub ExportDatabaseToSeparateFiles()
    'Export is based on the value in the KeyCol
        Dim myCell As Range
        Dim mySht As Worksheet
        Dim myName As String
        Dim myArea As Range
        Dim myShtName As String
        Dim KeyCol As String
        Dim myField As Integer

        myShtName = ActiveSheet.Name
        KeyCol = "C"

        Set myArea = Intersect(ActiveSheet.UsedRange, Range(KeyCol & "1").EntireColumn).Cells

        Set myArea = myArea.Offset(1, 0).Resize(myArea.Rows.Count - 1, 1)
        myField = myArea.Column - myArea.CurrentRegion.Cells(1).Column + 1

        For Each myCell In myArea
            On Error GoTo NoSheet
            myName = Worksheets(myCell.Value).Name
            GoTo SheetExists:
    NoSheet:
            Set mySht = Worksheets.Add(Before:=Worksheets(1))
            mySht.Name = myCell.Value
            With myCell.CurrentRegion
                .AutoFilter Field:=myField, Criteria1:=myCell.Value
                .SpecialCells(xlCellTypeVisible).Copy _
                        mySht.Range("A1")
                mySht.Cells.EntireColumn.AutoFit
                .AutoFilter
            End With
            Resume
    SheetExists:
        Next myCell

        For Each mySht In ActiveWorkbook.Worksheets
            If mySht.Name = myShtName Then
                Exit Sub
            Else
                mySht.Move
                ActiveWorkbook.SaveAs ActiveSheet.Name & ".xls"
                ActiveWorkbook.Close
            End If
        Next mySht
    End Sub


    HTH, Bernie

    • Proposed as answer by CSharpNoob2011 Thursday, August 9, 2012 4:25 PM
    • Marked as answer by Quist Zhang Saturday, August 11, 2012 6:51 PM
    Thursday, August 9, 2012 4:20 PM
  • this is working great.

    I've been trying to find a way to short it out as well.  it saves 1 folder behind.


    Please do not forget to click “Vote as Helpful” if the reply helps/directs you toward your solution and or "Mark as Answer" if it solves your question. This will help to contribute to the forum.

    Thursday, August 9, 2012 4:29 PM
  • Hello C#:

    Bernie is always "Quick to the Draw"... but here is another way to do the same thing.  This is actually an application.  I will upload the application to my SkyDrive.

    You open the workbook, click the button, navigate to the "All Clients" workbook, and it creates all the separate workbooks.  It also sorts the data by client name to make sure they are in the proper order.

    There are many ways to solve the same issue :)

    Option Explicit
    ' ************************************************
    ' Variables For File Open Dialogue Box
    ' ************************************************
    Dim strDialogueFileTitle As String
    Dim strFilt As String
    Dim intFilterIndex As Integer
    Dim strCancel As String
    Dim strWorkbookNameAndPath As String
    ' **************************************************
    ' Workbook And Worksheet Variables
    ' **************************************************
    Dim wkbAllClientsWorkbook As Workbook
    Dim wksAllClientsWorksheet As Worksheet
    Dim wkbNewClientWorkbook As Workbook
    Dim wksNewClientWorksheet As Worksheet
    
    Public Sub CreateClientWorkbooks()
    ' **************************************************
    ' Range Variables
    ' **************************************************
    Dim rngRangeToSort As Range
    Dim rngRangeOfClientNames As Range
    Dim rngClientDataToSave As Range
    Dim C As Range
    
    ' **************************************************
    ' Other Variables
    ' **************************************************
    Dim strSingleClientWorkbookPath As String
    Dim lngStartingRowForClientWorksheet As Long
    Dim lngEndingRowForClientWorksheet As Long
    Dim strLastClientName As String
    Dim lngNumberOfLinesInAllClients As Long
    
    Application.ScreenUpdating = False
    
    ' **************************************************
    ' Initialize Variables
    ' **************************************************
    strSingleClientWorkbookPath = "C:\Users\shekar\Desktop\Testing\"
    
    ' ****************************************************************************
    ' Set Up Filters For Which Files Should Show In The Open File Dialog Box
    ' ****************************************************************************
    strFilt = "Excel Files (*.xls),*.xls," & _
              "CSV Files (*.xlsx),*.xlsx,"
    
    ' ****************************************************************************
    ' Set Up The Prompt In The Dialogue Box
    ' ****************************************************************************
    intFilterIndex = 1
    strDialogueFileTitle = "Select The Daily Report"
    
    ' ****************************************************************************
    ' Present the Open File Dialogue To The User
    ' ****************************************************************************
    Call OpenFileDialogue
    
    ' ****************************************************************************
    ' Notify The User If No File Was Successfully Opened
    ' ****************************************************************************
    If strCancel = "Y" Then
        MsgBox ("An Open Error Occurred Importing Your File Selection")
        Exit Sub
    End If
    
    ' ********************************************************
    ' Set The Workbook and Worksheet Variables
    ' ********************************************************
    Set wkbAllClientsWorkbook = ActiveWorkbook
    Set wksAllClientsWorksheet = wkbAllClientsWorkbook.ActiveSheet
    
    ' ********************************************************
    ' Locate The Last Data Line In the "All Clients"
    ' ********************************************************
    lngNumberOfLinesInAllClients = wksAllClientsWorksheet.Cells(Rows.Count, "C").End(xlUp).Row
    
    ' ********************************************************
    ' Set The Sort Range - Assume 26 Columns of Data
    ' ********************************************************
    Set rngRangeToSort = Range(wksAllClientsWorksheet.Cells(2, 1), wksAllClientsWorksheet.Cells(lngNumberOfLinesInAllClients, 26))
    
    ' ********************************************************
    ' Sort The Worksheet By Client Name In Column A3
    ' ********************************************************
    rngRangeToSort.Sort Key1:=wksAllClientsWorksheet.Range("C2"), Order1:=xlAscending, _
                              Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
                              Orientation:=xlTopToBottom, _
                              DataOption1:=xlSortNormal
    
    ' *********************************************************
    ' Now That The Worksheet Is Sorted, Write Out New Workbooks
    ' For Each Unique Client Name
    ' *********************************************************
    Set rngRangeOfClientNames = Range(wksAllClientsWorksheet.Cells(2, 3), wksAllClientsWorksheet.Cells(lngNumberOfLinesInAllClients, 3))
    strLastClientName = wksAllClientsWorksheet.Cells(2, 3).Value
    lngStartingRowForClientWorksheet = 2
    
    For Each C In rngRangeOfClientNames
        If C.Value <> strLastClientName Then
            strLastClientName = C.Offset(-1, 0).Value
            lngEndingRowForClientWorksheet = C.Offset(-1, 0).Row
            Set rngClientDataToSave = Range(wksAllClientsWorksheet.Cells(lngStartingRowForClientWorksheet, 1), _
                                            wksAllClientsWorksheet.Cells(lngEndingRowForClientWorksheet, 26))
            Call AddNewClientWorkbook(strSingleClientWorkbookPath & strLastClientName & ".xls", rngClientDataToSave)
            lngStartingRowForClientWorksheet = C.Row
            strLastClientName = C.Value
        End If
    Next C
    ' *********************************************************
    ' Write Out Last Workbook
    ' *********************************************************
    strLastClientName = wksAllClientsWorksheet.Cells(lngNumberOfLinesInAllClients, 3).Value
    Set rngClientDataToSave = Range(wksAllClientsWorksheet.Cells(lngStartingRowForClientWorksheet, 1), _
                                    wksAllClientsWorksheet.Cells(lngNumberOfLinesInAllClients, 26))
    Call AddNewClientWorkbook(strSingleClientWorkbookPath & strLastClientName & ".xls", rngClientDataToSave)
    
    wkbAllClientsWorkbook.Close SaveChanges:=False
    
    Application.ScreenUpdating = True
    
    End Sub
    
    Private Sub OpenFileDialogue()
    
    ' ************************************************
    ' Display a File Open Dialogue Box For The User
    ' ************************************************
    strCancel = "N"
    strWorkbookNameAndPath = Application.GetOpenFilename _
        (FileFilter:=strFilt, _
         FilterIndex:=intFilterIndex, _
         Title:=strDialogueFileTitle)
       
    ' ************************************************
    ' Exit If No File Selected
    ' ************************************************
    If strWorkbookNameAndPath = "" Then
        MsgBox ("No Filename Selected")
        strCancel = "Y"
        Exit Sub
    ElseIf strWorkbookNameAndPath = "False" Then
        MsgBox ("You Clicked The Cancel Button")
        strCancel = "Y"
        Exit Sub
    End If
    
    ' ******************************************************
    ' Now That You Have The User Selected File Name, Open It
    ' ******************************************************
    Workbooks.Open strWorkbookNameAndPath
    
    End Sub
    
    Private Sub AddNewClientWorkbook(PathAndName As String, RangeOfOneClient As Range)
    ' ******************************************************
    ' This Creates A Workbook For A Unique Client
    ' ******************************************************
    Set wkbNewClientWorkbook = Workbooks.Add
    Set wksNewClientWorksheet = wkbNewClientWorkbook.Sheets(1)
    
    Range(wksAllClientsWorksheet.Cells(1, 1), wksAllClientsWorksheet.Cells(1, 26)).Copy wksNewClientWorksheet.Cells(1, 1)
    RangeOfOneClient.Copy wksNewClientWorksheet.Cells(2, 1)
    
    With wkbNewClientWorkbook
        .Title = "Client Sales"
        .Subject = "Sales"
        .SaveAs Filename:=PathAndName
    End With
    
    wkbNewClientWorkbook.Close
    
    End Sub
    

    Regards,


    Rich Locus, Logicwurks, LLC

    http://www.logicwurks.com

    • Proposed as answer by CSharpNoob2011 Thursday, August 9, 2012 6:10 PM
    • Marked as answer by Quist Zhang Saturday, August 11, 2012 6:51 PM
    Thursday, August 9, 2012 5:11 PM
  • Hello C#:

    Click on this link, and then right click on the "CreateUniqueClientWorkbooks" application, then select download.  It's "ready to run".  Just click the button.

    Create Unique Client Workbooks

    Regards,


    Rich Locus, Logicwurks, LLC

    http://www.logicwurks.com

    Thursday, August 9, 2012 5:15 PM
  • @Bernie:

    Wow!!  I reviewed and ran your code through the debugger... very creative ways to accomplish the mission.

    Regards,


    Rich Locus, Logicwurks, LLC

    http://www.logicwurks.com

    Thursday, August 9, 2012 5:42 PM
  • Hi Bernie,

    Thanks for your reply here is my below code it working very fine

        ChDir "C:\Documents and Settings\dn91742\Desktop\Testing"
        Workbooks.Open Filename:= _
            "C:\Documents and Settings\dn91742\Desktop\Testing\81a.xls"
        Selection.AutoFilter
        ActiveSheet.Range("$A$1:$S$205").AutoFilter Field:=3, Criteria1:="=0005*", _
            Operator:=xlAnd
        Range("A1:S205").Select
        Selection.Copy
        Workbooks.Add
        ActiveSheet.Paste
        Application.CutCopyMode = False
        ChDir "C:\Documents and Settings\dn91742\Desktop\Testing\Output"
        ActiveWorkbook.SaveAs Filename:= _
            "C:\Documents and Settings\dn91742\Desktop\Testing\Output\0005.xlsx", FileFormat _
            :=xlOpenXMLWorkbook, CreateBackup:=False
        ActiveWindow.Close
        ActiveWindow.LargeScroll ToRight:=-2
        ActiveSheet.Range("$A$1:$S$205").AutoFilter Field:=3, Criteria1:="=0006*", _
            Operator:=xlAnd
        Cells.Select
        Selection.Copy
        Workbooks.Add
        ActiveSheet.Paste
        Application.CutCopyMode = False
        ActiveWorkbook.SaveAs Filename:= _
            "C:\Documents and Settings\dn91742\Desktop\Testing\Output\0006.xlsx", FileFormat _
            :=xlOpenXMLWorkbook, CreateBackup:=False
        ActiveWindow.Close
        ActiveSheet.Range("$A$1:$S$205").AutoFilter Field:=3, Criteria1:="=0007*", _
            Operator:=xlAnd
        Cells.Select
        Selection.Copy
        Workbooks.Add
        ActiveSheet.Paste
        Application.CutCopyMode = False
        ActiveWorkbook.SaveAs Filename:= _
            "C:\Documents and Settings\dn91742\Desktop\Testing\Output"\0007.xlsx", FileFormat _
            :=xlOpenXMLWorkbook, CreateBackup:=False
        ActiveWindow.Close
        ActiveSheet.Range("$A$1:$S$205").AutoFilter Field:=3, Criteria1:="=0008*", _
            Operator:=xlAnd
        Selection.Copy
        Workbooks.Add
        ActiveSheet.Paste
        Application.CutCopyMode = False
        ActiveWorkbook.SaveAs Filename:= _
            "C:\Documents and Settings\dn91742\Desktop\Testing\Output"\0008.xlsx", FileFormat _
            :=xlOpenXMLWorkbook, CreateBackup:=False
        ActiveWindow.Close
        ActiveSheet.Range("$A$1:$S$205").AutoFilter Field:=3, Criteria1:="=5123*", _
            Operator:=xlAnd
        Selection.Copy
        Workbooks.Add
        ActiveSheet.Paste
        Application.CutCopyMode = False
        ActiveWorkbook.SaveAs Filename:= _
            "C:\Documents and Settings\dn91742\Desktop\Testing\Output"\5123.xlsx", FileFormat _
            :=xlOpenXMLWorkbook, CreateBackup:=False
        ActiveWindow.Close
        ActiveSheet.Range("$A$1:$S$205").AutoFilter Field:=3, Criteria1:="=5134*", _
            Operator:=xlAnd
        Selection.Copy
        Workbooks.Add
        ActiveSheet.Paste
        Application.CutCopyMode = False
        ActiveWorkbook.SaveAs Filename:= _
            "C:\Documents and Settings\dn91742\Desktop\Testing\Output"\5134.xlsx", FileFormat _
            :=xlOpenXMLWorkbook, CreateBackup:=False
        ActiveWindow.Close

    End Sub.

    The above code is creating each file like 0005.xls,0006.xls,0007.xls,0008.xls,5123.xls,& 5134.xls based on filter.

    I want to filter multiple Criteria1:="=0005, Criteria2:="=0006,Criteria3:="=0007, Criteria4:="=0008,Criteria5:="=5123,Criteria5:="=5134 & save in

    ActiveWorkbook.SaveAs Filename:= _
            "C:\Documents and Settings\dn91742\Desktop\Testing\Output"\ABC.xlsx", FileFormat _
            :=xlOpenXMLWorkbook, CreateBackup:=False


    • Edited by adcz250 Thursday, August 9, 2012 6:14 PM
    • Marked as answer by Quist Zhang Saturday, August 11, 2012 6:51 PM
    Thursday, August 9, 2012 6:11 PM
  • i've always appreciated your help Rich.

    Your codes are very userfriendly, especially for fools like myself.


    Please do not forget to click “Vote as Helpful” if the reply helps/directs you toward your solution and or "Mark as Answer" if it solves your question. This will help to contribute to the forum.

    Thursday, August 9, 2012 6:11 PM
  • Are you a C# developer?  I have a love/hate relationship with C#.  It should be sooooo easy to use C#...yet it is so sooooo difficult to use it...  Anyway, here is another solution for you to consider:

    http://www.rondebruin.nl/copy6.htm


    Ryan Shuell

    Saturday, August 18, 2012 5:29 AM