Split One tab into Multiple Files with Specific Names

[Jsubby3]

Hello All,

I have been searching up and down trying to plagiarize various code to get this to work. I have a file that lists a series of data for all suppliers, weekly I would like to be able to split these into individual files by supplier and automatically name them as the Supplier name. An example of my data is below, header starts in cell A5 and goes to R5 - obviously would need the headers to be in each individual file. Any help would be greatly, greatly appreciated

Purch. Organization	Plant	Vendor	Name	Purchasing Document	Item	Purchasing Doc. Type	Purchasing Group	Material	Material Description	Schedule Line	Scheduled Quantity	PO UOM	Received Qty Purch UOM	Open Qty Purch UOM	Delivery Date	Stat.-Rel. Del. Date	Delivery Completed
1000	1000	214	Supplier A	64741	20	NB	001	part 1		2	1.000	M2	0.000	1.000	9/30/2017	9/30/2017
1000	1000	432	Supplier B	123	20	NB	001	part 2		1	1.000	M2	0.000	1	9/30/2017	9/30/2017

<tbody>
</tbody>

 

[oldbrewer]

if you copied everything to a new sheet and filtered by Supplier A, and copied everything to a second sheet and filtered by supplier B ?

or sorted original sheet by supplier ascending ? What are you going to do with just supplier A data ?

 

[Fluff]

How about this

Sub FltrCopy()

    Dim Dict As Object
    Dim Ky As Variant
    Dim Cl As Range
    Dim UsdRws As Long

    Set Dict = CreateObject("scripting.dictionary")

    With Sheets("Data List")
        UsdRws = .Range("D" & Rows.Count).End(xlUp).Row
    
        For Each Cl In .Range("D2:D" & UsdRws)
            If Not Dict.exists(Cl.Value) Then Dict.Add Cl.Value, Nothing
        Next Cl
    
        For Each Ky In Dict.keys
            Sheets.Add.Name = Ky
            .Range("A1").AutoFilter field:=4, Criteria1:=Ky
            .Range("A1:R" & UsdRws).SpecialCells(xlVisible).Copy Range("A1")
        Next Ky
        .AutoFilterMode = False
    End With

End Sub

 

[Jsubby3]

That wold work but I have over 100 suppliers. I take my master report, break it down by supplier then send it to them

 

[Fluff]

In that case

Sub FltrCopy()

    Dim Dict As Object
    Dim Ky As Variant
    Dim Cl As Range
    Dim UsdRws As Long

Application.ScreenUpdating = False
    Set Dict = CreateObject("scripting.dictionary")

    With Sheets("Data List")
        UsdRws = .Range("D" & Rows.Count).End(xlUp).Row
    
        For Each Cl In .Range("D2:D" & UsdRws)
            If Not Dict.exists(Cl.Value) Then Dict.Add Cl.Value, Nothing
        Next Cl
    
        For Each Ky In Dict.keys
            Workbooks.Add (1)
            Sheets(1).Name = Ky
            .Range("A1").AutoFilter field:=4, Criteria1:=Ky
            .Range("A1:R" & UsdRws).SpecialCells(xlVisible).Copy Range("A1")
            ActiveWorkbook.SaveAS "[COLOR=#0000ff]C:\Users\Fluff\Desktop\test\[/COLOR]" & Ky, 51
            ActiveWorkbook.Close
        Next Ky
        .AutoFilterMode = False
    End With

End Sub

Change the part in blue to match your folder path

 

[Jsubby3]

I keep getting a "subscript out of range" error - is there a named range in your example or does it have to do with my data starting in Cell A5?

 

[Jsubby3]

Ok I got past the subscript out of range. I can cycle through the code until

Sheets(1).Name = Ky

it opens a new workbook but then I get the error "Application-defined or object-defined error" no data gets pasted into the newly created sheet

 

[Fluff]

Ok, try

Sub FltrCopy()

    Dim Dict As Object
    Dim Ky As Variant
    Dim Cl As Range
    Dim UsdRws As Long
    Dim Wbk As Workbook

Application.ScreenUpdating = False
    Set Dict = CreateObject("scripting.dictionary")

    With Sheets("[COLOR=#ff0000]Data List[/COLOR]")
        UsdRws = .Range("D" & Rows.Count).End(xlUp).Row
    
        For Each Cl In .Range("D6:D" & UsdRws)
            If Not Dict.exists(Cl.Value) Then Dict.Add Cl.Value, Nothing
        Next Cl
    
        For Each Ky In Dict.keys
            Set Wbk = Workbooks.Add(1)
            Wbk.Sheets(1).Name = Ky
            .Range("A1").AutoFilter field:=4, Criteria1:=Ky
            .Range("A1:R" & UsdRws).SpecialCells(xlVisible).Copy Range("A1")
            ActiveWorkbook.SaveAS "C:\Users\Fluff\Desktop\test\" & Ky, 51
            ActiveWorkbook.Close
        Next Ky
        .AutoFilterMode = False
    End With

End Sub

One thing I forgot to mention, you need to change the part in red to match your sheet name.
Also its based on the Supplier name being in col D and that the names do not include illegal characters such as / \ ?

 

[Fluff]

Please ignore the code in post#8, It's been a long day.

Sub FltrCopy()

    Dim Dict As Object
    Dim Ky As Variant
    Dim Cl As Range
    Dim UsdRws As Long
    Dim Wbk As Workbook

Application.ScreenUpdating = False
    Set Dict = CreateObject("scripting.dictionary")

    With Sheets("Data List")
        UsdRws = .Range("D" & Rows.Count).End(xlUp).Row
    
        For Each Cl In .Range("D2:D" & UsdRws)
            If Not Dict.exists(Cl.Value) Then Dict.Add Cl.Value, Nothing
        Next Cl
    
        For Each Ky In Dict.keys
            Set Wbk = Workbooks.Add(1)
            Wbk.Sheets(1).Name = Ky
            .Range("A5").AutoFilter field:=4, Criteria1:=Ky
            .Range("A6:R" & UsdRws).SpecialCells(xlVisible).Copy Range("A1")
            Wbk.SaveAS "C:\Users\DaveC\Desktop\test\" & Ky, 51
            Wbk.Close
        Next Ky
        .AutoFilterMode = False
    End With

End Sub

 

[RobertSF]

I'm doing something similar, so thanks for that post, especially the tip about dictionaries.

To the other poster, if it's not working, it may be because you haven't added a reference to Microsoft Scripting Runtime. See http://www.snb-vba.eu/VBA_Dictionary_en.html