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]

 

[Mandy_84]

well, the code splits & saves the data into different files, however those files are not excel

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

 

[Fluff]

Could you please post the exact code that you are using?

 

[Mandy_84]

Could you please post the exact code that you are using?

Please see below modified with my data
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("sheet1")
UsdRws = .Range("AA" &Rows.Count).End(xlUp).Row

For Each Cl In.Range("AA2:AA" & UsdRws)
If Not Dict.exists(Cl.Value) ThenDict.Add Cl.Value, Nothing
Next Cl

For Each Ky In Dict.keys
Set Wbk = Workbooks.Add(1)
Wbk.Sheets(1).Name = Ky
.Range("A1").AutoFilterfield:=27, Criteria1:=Ky
.Range("A2:AP" &UsdRws).SpecialCells(xlVisible).Copy Range("A1")
Wbk.SaveAs"C:\Users\5271467\Desktop\test" & Ky, 42
Wbk.Close
Next Ky
.AutoFilterMode = False

End With

End Sub

 

[Fluff]

Change the number in red to an Xl fileformat

[FONT=Calibri]Wbk.SaveAs"C:\Users\5271467\Desktop\test" & Ky, [COLOR=#ff0000]42[/COLOR][/FONT]

See here for details
https://www.rondebruin.nl/win/s5/win001.htm

 

[Mandy_84]

right, Thanks

Change the number in red to an Xl fileformat

[FONT=Calibri]Wbk.SaveAs"C:\Users\5271467\Desktop\test" & Ky, [COLOR=#ff0000]42[/COLOR][/FONT]

See here for details
https://www.rondebruin.nl/win/s5/win001.htm

 

[Fluff]

You're welcome