Splitting out data into different workbooks

[JayB0730]

Hello,

I have a spreadsheet that contains several columns similar to the below:

	A	B	C	D	E	F	G
1					Report Date:	6/22/18
2	First Name	Last Name	Category	Sub Category	Reg Code	Dist Code	Area Code
3	Jon	Doe	Fruit	Apple	11	000	00
4	Jane	Doe	Fruit	Apple	11	001	00
5	Jack	Doe	Fruit	Apple	11	001	01
6	Mary	Doe	Fruit	Apple	11	002	00
7	Jasper	Test	Fruit	Apple	11	002	01
8	Veronica	Test	Fruit	Orange	12	000	00
9	Angel	Test	Fruit	Orange	12	001	00
10	Jim	Doe	Fruit	Orange	12	001	01
11	Jess	Grass	Veggie	Carrot	13	000	00
12	June	High	Veggie	Carrot	13	001	00
13	Jen	One	Veggie	Carrot	13	001	01

<tbody>
</tbody>

What I would like to be able to do is the following:

1. Create different workbooks (This example would result in 3 workbooks) that contain the same data where Reg Code (2 characters always) is the same.
2. Each workbook would contain the rows of information where Reg Code is the same; however, I would NOT like to include any rows containing "00" in the Area Code field.
3. Lines 1 and 2 would be copied over each time.
4. Create each file name based on "[Category]_[Sub Category]_MMMYYYY.xlsx"

TIA!

 

[JLGWhiz]

See if this works for you

Sub t()
Dim wb As Workbook, sh As Worksheet, rng As Range, c As Range, r As Range, lr As Long, fName As String
Set sh = ThisWorkbook.ActiveSheet
lr = sh.Cells.Find("*", , xlValues, xlPart, xlByRows, xlPrevious).Row
Set rng = sh.Range("E2", sh.Cells(Rows.Count, 5).End(xlUp))
rng.AdvancedFilter xlFilterCopy, , sh.Range("A" & lr + 2), True
    For Each c In sh.Range("A" & lr + 2).CurrentRegion.Offset(1)
        If c <> "" Then
            Set wb = Workbooks.Add
            sh.Range("1:2").EntireRow.Copy wb.Sheets(1).Range("A1")
            rng.AutoFilter 1, c.Value
            For Each r In rng.Offset(1).SpecialCells(xlCellTypeVisible)
                If r <> "" And r.Offset(, 2) <> "00" Then
                    r.EntireRow.Copy wb.Sheets(1).Cells(Rows.Count, 1).End(xlUp)(2)
                End If
            Next
            sh.AutoFilterMode = False
            fName = wb.Sheets(1).Range("C3").Value & "_" & wb.Sheets(1).Range("D3").Value & "_" & Format(Date, "mmmyyyy") & ".xlsx"
            wb.SaveAs "Reg Code " & c.Value & ".xlsx"
            wb.Close True
            Set wb = Nothing
        End If
    Next
sh.Range("A" & lr + 2).CurrentRegion.ClearContents
End Sub

 

[Fluff]

Another option

Sub Filter2Wbk()
   Dim Ws As Worksheet
   Dim Cl As Range
   Dim Dic As Object
   
   Application.ScreenUpdating = False
   Set Dic = CreateObject("scripting.dictionary")
   Set Ws = ActiveSheet
   
   If Ws.AutoFilterMode Then Ws.AutoFilterMode = False
   For Each Cl In Ws.Range("G3", Ws.Range("G" & Rows.count).End(xlUp))
      If Cl.Value <> "00" Then Dic(CStr(Cl.Value)) = Empty
   Next Cl
   With CreateObject("scripting.dictionary")
      For Each Cl In Ws.Range("E3", Ws.Range("E" & Rows.count).End(xlUp))
         If Not .Exists(Cl.Value) Then
            .Add Cl.Value, Cl.Offset(, -2).Value & "_" & Cl.Offset(, -1).Value & "_" & format(Date, "MMMYYYY")
            Ws.Range("A2:G2").AutoFilter 5, Cl.Value
            Ws.Range("A2:G2").AutoFilter 7, Dic.keys
            Workbooks.Add
            Ws.UsedRange.SpecialCells(xlVisible).Copy Range("A1")
            ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & .Item(Cl.Value) & ".xlsx", 51
            ActiveWorkbook.Close False
         End If
      Next Cl
   End With
   Ws.AutoFilterMode = False
End Sub

 

[JayB0730]

First, I would like to thank you both very much for your help. I started with Fluff's code and received an error message on the following line:

[COLOR=#333333]Ws.UsedRange.SpecialCells(xlVisible).Copy Range("A1")[/COLOR]

"Run time error 1004. Application Defined or Object Defined error". Not sure what to do from here.

 

[JayB0730]

I believe I got it to work now. It appears that

.Copy Range ("A1")

does not seem to work; however,

.Copy Destination:=[A1]

does. Thoughts? Is that the right syntax?

First, I would like to thank you both very much for your help. I started with Fluff's code and received an error message on the following line:

[COLOR=#333333]Ws.UsedRange.SpecialCells(xlVisible).Copy Range("A1")[/COLOR]

"Run time error 1004. Application Defined or Object Defined error". Not sure what to do from here.

 

[Fluff]

Both of those lines are the same (just a different way of righting it), but if that works for you, then go for it.

 

[JayB0730]

Thanks. I do have another issue. I updated the code to be applied to a larger data set. However, for some reason it it is creating blank files. Or it is only copying a random line into one of the files. I made sure to update your code to fit the same columns and rows in the new file. Not sure why that is?

Sub Filter2Wbk()   Dim Ws As Worksheet
   Dim Cl As Range
   Dim Dic As Object
   
   Application.ScreenUpdating = False
   Set Dic = CreateObject("scripting.dictionary")
   Set Ws = ActiveSheet
   
   If Ws.AutoFilterMode Then Ws.AutoFilterMode = False
   For Each Cl In Ws.Range("Y3", Ws.Range("Y" & Rows.Count).End(xlUp)) 'Last column in Roster File should be "Y".  This should be called "TERR" If not, structure is not correct.
      If Cl.Value <> "00" Then Dic(CStr(Cl.Value)) = Empty
   Next Cl
   With CreateObject("scripting.dictionary")
      For Each Cl In Ws.Range("W3", Ws.Range("W" & Rows.Count).End(xlUp)) '3rd to last column in Roster File should be "W". This should be called "REG". If not, structure is not correct.
         If Not .Exists(Cl.Value) Then
            .Add Cl.Value, Cl.Offset(, -22).Value & "_" & Cl.Offset(, -19).Value & "_" & Format(Date, "MMMYYYY") '-22 = "SELL DIV NAME"; -19 = "Position Description"
            Ws.Range("A2:Y2").AutoFilter 23, Cl.Value
            Ws.Range("A2:Y2").AutoFilter 25, Dic.keys
            Workbooks.Add
            Ws.UsedRange.SpecialCells(xlVisible).Copy Destination:=[A1]
            ActiveWorkbook.SaveAs "C:\Users\xxxx\Desktop\Test" & "\" & .Item(Cl.Value) & ".xlsx", 51 '********THIS MUST BE UPDATED TO THE CORRECT DESTINATION FOLDER!***********
            ActiveWorkbook.Close False
         End If
      Next Cl
   End With
   Ws.AutoFilterMode = False
   MsgBox "PROCESS COMPLETE!", vbOKOnly
End Sub

 

[Fluff]

If you step through the code using F8, when you get to the Workbooks.add line, check that the data has been filtered correctly.

 

[JayB0730]

Hi,

Yeah i'm still a novice at VBA but that is exactly what I was trying to do and I am having trouble understanding the issue. Can you explain what the following lines are doing. I am not understanding the difference between Autofilter on Cl.Value vs. Autofilter on Dic.keys.

Ws.Range("A2:Y2").AutoFilter 23, Cl.Value
Ws.Range("A2:Y2").AutoFilter 25, Dic.keys

 

[Fluff]

The first line is filtering on the values in col W.
As I couldn't get it to filter on <>00 I put all the values in the Area Code column (excluding 00) into a dictionary & the second line then filters on that