Create multiple workbooks from one single workbook based on Customer code

[padariar]

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

 

[wongm003]

You could try...

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

 

[Fazza]

Hi,

Freeware at this site looks relevant & might be helpful. I have not tried it. http://www.datapigtechnologies.com/freeware.htm

regards, Fazza

 

[dwhims]

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

 

[Fazza]

The internet is a truly amazing resource for learning