Split One tab into Multiple Files with Specific Names

Jsubby3

New Member
Joined
Oct 24, 2016
Messages
14
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. OrganizationPlantVendorNamePurchasing DocumentItemPurchasing Doc. TypePurchasing GroupMaterialMaterial DescriptionSchedule LineScheduled QuantityPO UOMReceived Qty Purch UOMOpen Qty Purch UOMDelivery DateStat.-Rel. Del. DateDelivery Completed
10001000214Supplier A6474120NB001part 121.000M20.0001.0009/30/20179/30/2017
10001000432Supplier B12320NB001part 211.000M20.00019/30/20179/30/2017

<tbody>
</tbody>
 

Some videos you may like

Excel Facts

Repeat Last Command
Pressing F4 adds dollar signs when editing a formula. When not editing, F4 repeats last command.

oldbrewer

Board Regular
Joined
Apr 11, 2010
Messages
11,003
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

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
46,054
Office Version
  1. 365
Platform
  1. Windows
How about this
Code:
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

New Member
Joined
Oct 24, 2016
Messages
14
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

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
46,054
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

In that case
Code:
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

New Member
Joined
Oct 24, 2016
Messages
14
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

New Member
Joined
Oct 24, 2016
Messages
14

ADVERTISEMENT

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

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
46,054
Office Version
  1. 365
Platform
  1. Windows
Ok, try
Code:
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

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
46,054
Office Version
  1. 365
Platform
  1. Windows
Please ignore the code in post#8, It's been a long day.
Code:
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
 

Watch MrExcel Video

Forum statistics

Threads
1,108,579
Messages
5,523,705
Members
409,531
Latest member
Lmfacc

This Week's Hot Topics

Top