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

[TABLE="width: 2157"]
<tbody>[TR]
[TD]Purch. Organization[/TD]
[TD]Plant[/TD]
[TD]Vendor[/TD]
[TD]Name[/TD]
[TD]Purchasing Document[/TD]
[TD]Item[/TD]
[TD]Purchasing Doc. Type[/TD]
[TD]Purchasing Group[/TD]
[TD]Material[/TD]
[TD]Material Description[/TD]
[TD]Schedule Line[/TD]
[TD]Scheduled Quantity[/TD]
[TD]PO UOM[/TD]
[TD]Received Qty Purch UOM[/TD]
[TD]Open Qty Purch UOM[/TD]
[TD]Delivery Date[/TD]
[TD]Stat.-Rel. Del. Date[/TD]
[TD]Delivery Completed[/TD]
[/TR]
[TR]
[TD]1000[/TD]
[TD]1000[/TD]
[TD="align: right"]214[/TD]
[TD]Supplier A[/TD]
[TD="align: right"]64741[/TD]
[TD]20[/TD]
[TD]NB[/TD]
[TD]001[/TD]
[TD]part 1[/TD]
[TD][/TD]
[TD]2[/TD]
[TD]1.000[/TD]
[TD]M2[/TD]
[TD]0.000[/TD]
[TD]1.000[/TD]
[TD]9/30/2017[/TD]
[TD]9/30/2017[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]1000[/TD]
[TD]1000[/TD]
[TD="align: right"]432[/TD]
[TD]Supplier B[/TD]
[TD="align: right"]123[/TD]
[TD]20[/TD]
[TD]NB[/TD]
[TD]001[/TD]
[TD]part 2[/TD]
[TD][/TD]
[TD]1[/TD]
[TD]1.000[/TD]
[TD]M2[/TD]
[TD]0.000[/TD]
[TD]1[/TD]
[TD]9/30/2017[/TD]
[TD]9/30/2017[/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

 

[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