Macro to create new workbooks from current workbook data

[Dramsey]

I have a table with 7 columns. Cust Id, Customer name, cust part number, cust description, our part number, price, uom. I need to create a workbook for each customer (782 total workbooks/customers) that has columns 3 to 7, each customer has multiple rows for each item(over 16000 rows), but no 2 customers necessarily share the same product selection. Also need this with the headers and saved as cust id for filename. Can a macro do this automatically?

 

[Dramsey]

Group	FirstOfCustomer	FirstOfItem Number	FirstOfSC New Item Combined	FirstOfWatts_Desc	Import_Net	FirstOfUM_Conv_Factor	FirstOfUM
B J PLUMBING	B J PLUMBING SUPPLY	0123936	637-B23HWP	Watts LFA-158A 3/8Cx3/4 Elbow	$	1	EA
B J PLUMBING	B J PLUMBING SUPPLY	0123936	637-B23HWP	Watts LFA-158A 3/8Cx3/4 Elbow	$	1	EA
B&D	00334310	0121009	134-G2S0CR104	Watts LF892151	$	1	EA
B&D	00334310	0147033	134-G2S1CE504	Watts LF892503	$	1	EA
B&D	00334310	0147097	133-G2S1CE504	Watts LF892513	$	1	EA
B&D	00334310	0147099	133-G2S1CR104	Watts LF892011	$	1	EA
B&G SPECIALTY	B & G SPECIALITY COMPANY	0142388	696WVH12	Watts 1/2 175C WASHING MACH	$	1	EA
B&G SPECIALTY	B & G SPECIALITY COMPANY	0142388	696WVH12	Watts 1/2 175C WASHING MACH	$	1	EA

<tbody>
</tbody>

 

[John_w]

Welcome to MrExcel forums.

A few pointers to do this: get a list of unique customer ids (either using Advanced Filter on the Cust Id column to put unique Cust Ids in a temporary sheet, or loop through the Cust Ids adding them to a VBA Collection or Dictionary object, to get a list of unique Cust Ids); then for each unique Cust Id, copy the main sheet to a separate sheet, then advanced filter or autofilter against that Cust Id, delete unwanted columns 1-2, save the sheet as a workbook with Cust Id as the file name. Start by recording macros to do each part of the process, and search this forum for the bits of code to glue it all together.

 

[Dramsey]

Here it is for anyone else that may be interested

Sub TopFolder()

Set myFolder = Application.FileDialog(msoFileDialogFolderPicker)
With myFolder
.Title = "Choose Folder"
.AllowMultiSelect = False
If .Show <> -1 Then
Exit Sub
End If
FolderSelected = .SelectedItems(1)
End With


Worksheets("Run").Range("C9").Value = FolderSelected


End Sub


Sub CreateGroups()


If Sheets("Run").Range("C9").Value = "" Then
    MsgBox "Please browse to the top level folder before running macro."
    Exit Sub
End If


Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual


Dim thisWb, newWb As Workbook
Dim dRow, dEnd, fRow, groupCnt As Long
Dim path, newName As String


groupCnt = 0
dRow = 2
fRow = 2
dEnd = Sheets(2).UsedRange.Rows.Count


'Sort data by group
On Error Resume Next
Sheets(2).Range("A2:Z" & dEnd).Sort _
    Key1:=Sheets(2).Range("A2"), Order1:=xlAscending, _
    Key2:=Sheets(2).Range("C2"), Order2:=xlAscending, Header:=xlNo
    
Set thisWb = ActiveWorkbook


'Read through data, when Group changes, create folder and spreadsheet
Do While dRow <= dEnd
    
    If dRow <> 2 And thisWb.Sheets(2).Cells(dRow, 1).Value <> thisWb.Sheets(2).Cells(dRow - 1, 1).Value Then
        
        'Create folder
        path = thisWb.Sheets("Run").Range("C9").Value & "\" & thisWb.Sheets(2).Cells(fRow, 1).Value
        
        If Len(Dir(path, vbDirectory)) = 0 Then
            MkDir path
        End If
        
        'Create new file
        Set newWb = Workbooks.Add
        newName = path & "\" & thisWb.Sheets(2).Cells(fRow, 1).Value & ".xlsx"


        'Delete File
        On Error Resume Next
        Kill newName


        'Copy headings to Sheet1
        thisWb.Sheets(2).Range("C1:H1").Copy
        With newWb.Sheets(1).Range("A1")
            .Cells(1).PasteSpecial xlPasteColumnWidths
            .Cells(1).PasteSpecial xlPasteValues
            .Cells(1).PasteSpecial xlPasteFormats
            Application.CutCopyMode = False
        End With


        'Copy values to Sheet1
        thisWb.Sheets(2).Range("C" & fRow & ":H" & dRow - 1).Copy
        With newWb.Sheets(1).Range("A2")
            .Cells(1).PasteSpecial xlPasteColumnWidths
            .Cells(1).PasteSpecial xlPasteValues
            .Cells(1).PasteSpecial xlPasteFormats
            Application.CutCopyMode = False
        End With
    
        newWb.Sheets(1).Range("A1").Select


        With newWb
            .SaveAs newName
        End With
        
        newWb.Close
        
        groupCnt = groupCnt + 1
        fRow = dRow
    End If
    
    dRow = dRow + 1
Loop


Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic


MsgBox groupCnt & " groups were processed."


End Sub