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]

 

[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.