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>

 

[Jsubby3]

Correct the data is copied into my original file

 

[Fluff]

Your system obviously works different to mine, as when I create a new workbook, it automatically becomes the active book.
See if this fixes the problem

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("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("A5").AutoFilter Field:=4, Criteria1:=Ky
            .Range("A5:R" & UsdRws).SpecialCells(xlVisible).Copy Wbk.Sheets(Ky).Range("A1")
            Wbk.SaveAS "C:\Users\Davec\Desktop\test\" & Ky, 51
            Wbk.Close
        Next Ky
        .AutoFilterMode = False
    End With

End Sub

 

[Jsubby3]

Nailed it... Thanks for sticking it out, much appreciated!

 

[Fluff]

No worries, glad to help & thanks for the feedback

 

[Jsubby3]

I was feeling awesome about this until I expanded my data and ran into an issue. The Macro works as intended but it is naming the tab by the vendor name, nice touch however some of my supplier names exceed the maximum amount of characters allowed by Excel so the loop fails when it hits one of those suppliers. I tried a number of things but haven't been able to change your code to correct it.

 

[Fluff]

OK, one option is this

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("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)
            [COLOR=#0000ff]If Len(Ky) > 31 Then
                Wbk.Sheets(1).Name = Left(Ky, 31)
            Else
                Wbk.Sheets(1).Name = Ky
            End If[/COLOR]
            .Range("A5").AutoFilter Field:=4, Criteria1:=Ky
            .Range("A5:R" & UsdRws).SpecialCells(xlVisible).Copy Wbk.Sheets(1).Range("A1")
            Wbk.SaveAS "C:\Users\Fluff\Desktop\test\" & Ky, 51
            Wbk.Close
        Next Ky
        .AutoFilterMode = False
    End With

End Sub

The lines in blue will name the sheet with the vendors name & if the name is more then 31 characters, then it will truncate the name to the first 31 characters.
Another option, simply delete the lines in blue & the sheet will use the default name of Sheet1

 

[Jsubby3]

Worked perfect, thanks again for your help

 

[Fluff]

My pleasure

 

[Mandy_84]

Hi All! Why it doesn't save me in excel 2016????

OK, one option is this

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("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)
            [COLOR=#0000ff]If Len(Ky) > 31 Then
                Wbk.Sheets(1).Name = Left(Ky, 31)
            Else
                Wbk.Sheets(1).Name = Ky
            End If[/COLOR]
            .Range("A5").AutoFilter Field:=4, Criteria1:=Ky
            .Range("A5:R" & UsdRws).SpecialCells(xlVisible).Copy Wbk.Sheets(1).Range("A1")
            Wbk.SaveAS "C:\Users\Fluff\Desktop\test\" & Ky, 51
            Wbk.Close
        Next Ky
        .AutoFilterMode = False
    End With

End Sub

The lines in blue will name the sheet with the vendors name & if the name is more then 31 characters, then it will truncate the name to the first 31 characters.
Another option, simply delete the lines in blue & the sheet will use the default name of Sheet1

 

[Fluff]

@Mandy_84
Could you please be a bit more specific? I don't understand what you are saying.