VBA: Splitting excel files based on a category in the data

[nataliejdv]

Hi all, question about VBA in excel here..

In essence we want to create a VBA code that automatically creates Workbooks for each type of store.

As an example:
We have one source workbook with the following table:

Type of store	Seller	Item	Price
A	Youtube	Banana	5,00
B	Youtube	Apple	6,00
A	Google	Apple	7,00
C	Google	Pear	5,00
B	Amazon	Citron	4,50
C	BrandinGstore	Banana	0,50

<tbody>
</tbody>

What we want to achieve with the VBA code for the table above is three separate workbooks for Type of store A, B and C. The workbook needs to have the name of the Type of store. So it would look like:
Filename; ‘A.xls’

Type of store	Seller	Item	Price
A	Youtube	Banana	5,00
A	Google	Apple	7,00

<tbody>
</tbody>

Filename; ‘B.xls’

Type of store	Seller	Item	Price
B	Youtube	Apple	6,00
B	Amazon	Citron	4,50

<tbody>
</tbody>

Filename; ‘C.xls’

Type of store	Seller	Item	Price
C	Google	Pear	5,00
C	BrandinGstore	Banana	0,50

<tbody>
</tbody>

I had a go with a very crude way of doing it (see below) but there are a few things missing:

1. An efficient loop
2. The Windows(“Map4”).Activate messes up a potential loop ?
3. And a way of naming the file according to the ‘Type of store’

Sub Macro1()

ActiveSheet.Range("$A$1:$A$8" & "$C$1:$C$8" ).AutoFilter Field:=2, Criteria1:="aa"
Workbooks.Add
Windows("Test_split file.xlsm").Activate
Range("A1:C8").Select
Selection.Copy
Windows("Map4").Activate
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveWorkbook.SaveAs Filename:="C:\Users\bjprent\Documents\aa.xlsx", _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
ActiveWindow.Close

ActiveSheet.Range("$A$1:$C$8").AutoFilter Field:=2, Criteria1:="bb"
Workbooks.Add
Windows("Test_split file.xlsx").Activate
Range("A1:C8").Select
Selection.Copy
Windows("Map4").Activate
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveWorkbook.SaveAs Filename:="C:\Users\bjprent\Documents\bb.xlsx", _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
ActiveWindow.Close

End Sub

Hope someone can help,
Thank you!

 

[Fluff]

How about

Sub SplitBook()
   Dim Cl As Range
   Dim Ws As Worksheet
   
   Set Ws = Sheets("Pcode")
   If Ws.AutoFilterMode Then Ws.AutoFilterMode = False
   With CreateObject("scripting.dictionary")
      For Each Cl In Ws.Range("A2", Ws.Range("A" & Rows.count).End(xlUp))
         If Not .exists(Cl.Value) Then
            .Add Cl.Value, Nothing
            Ws.Range("A1:D1").AutoFilter 1, Cl.Value
            Workbooks.Add
            Ws.AutoFilter.Range.Copy Range("A1")
            ActiveWorkbook.SaveAs C:\Users\bjprent\Documents\" & Cl.Value & ".xlsx", 51
            ActiveWorkbook.Close False
         End If
      Next Cl
   End With
   Ws.AutoFilterMode = False
End Sub