Create multiple workbooks from one single workbook based on Customer code

padariar

New Member
Joined
Aug 4, 2003
Messages
8
Hello All,

I have an excel file which contains following data in it.

Col-A Col-B Col-C ......
Cust Cd Name Sales
=======================
101 AAA 1000
101 AAA 500
101 AAA 3000
102 BBB 800
102 BBB 200
103 CCC 200
103 CCC 200
103 CCC 200

I need to create following three workbooks with name based on Cust Cd from above excel file.
Workbook - 1 : 101.xls which contains records only pertaining to Cust Cd 101.
Workbook - 2 : 102.xls which contains records only pertaining to Cust Cd 102.
Workbook - 3 : 103.xls which contains records only pertaining to Cust Cd 103.

Does anybody has idea how to do it ?

Thanks well in advance !

Kind Regards,

Raju C Padaria
FAG, India
 

Some videos you may like

Excel Facts

Excel motto
Not everything I do at work revolves around Excel. Only the fun parts.

wongm003

Board Regular
Joined
Aug 8, 2005
Messages
237
You could try...

Code:
Public Sub create_new_wbs()
'============================================================
' author: wongm003
' date: 08-03-08
'
' assumptions:
'   Header on row 1 with data starting on row 2
'   data exists from column A to last column in header
'   last row of data is the same as last row of data for the filter column
'============================================================
On Error GoTo hndl_err:
    Const strCol As String = "A"    'Filter column

    Dim src As Workbook
    Dim dst As Workbook
    Dim objDic
    Dim keyVal
    Dim lr As Long
    Dim lc As Integer
    Dim intCol As Integer
    Dim i As Integer
    
    Set src = ActiveWorkbook
    Application.ScreenUpdating = False
    
    'determine last row of data to filter
    lr = Range(strCol & Rows.Count).End(xlUp).Row
    
    'determine last column in header (row 1)
    lc = Range("IV1").End(xlToLeft).Column
    
    'if no data exit sub
    If lr = 1 And lc = 1 Then GoTo normal_exit
    
    'determine column number for filter
    intCol = Columns(strCol).Column
    
    Set objDic = CreateObject("Scripting.Dictionary")
       
    'determine distinct codes -- start with row after header
    For Each c In Range(Cells(2, intCol), Cells(lr, intCol))
        'if cell value not blank
        If Len(Trim(c.Value)) > 0 Then
            'add cell value if not already in dictionary object
            If Not objDic.Exists(c.Value) Then objDic.Add c.Value, c.Value
        End If
    Next c
    
    keyVal = objDic.keys

    'copy rows to new workbook for each code
    For i = 0 To objDic.Count - 1
        With Range(Cells(1, 1), Cells(lr, lc))
            .AutoFilter Field:=intCol, Criteria1:=keyVal(i)
            .Copy
        End With
        Set dst = Workbooks.Add
        Cells(1, 1).Select
        ActiveSheet.Paste
        'save new workbook in same directory as current workbook with code as the file name
        dst.SaveAs (src.Path & "\" & keyVal(i) & ".xls")
        dst.Close
        src.Activate
    Next i

    'remove filter
    Range(Cells(1, 1), Cells(lr, lc)).AutoFilter

normal_exit:
    Application.ScreenUpdating = True
    Exit Sub
    
hndl_err:
    MsgBox Err.Description
    Resume normal_exit

End Sub
 

dwhims

Board Regular
Joined
Sep 10, 2003
Messages
155
You guys ROCK!!! 5 years later, and this code still works like a charm. I found myself needing to do exactly what padariar did, and this fit the bill perfectly.

Thanks!!!
 

Watch MrExcel Video

Forum statistics

Threads
1,123,047
Messages
5,599,497
Members
414,315
Latest member
Yolanda5050

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top