Splitting out data into different workbooks

J

JayB0730

Board Regular
Joined
Oct 22, 2014
Messages
74
Office Version
  1. 365
Platform
  1. Windows
Hello,

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

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


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!
 
Last edited:

Excel Facts

Difference between two dates
Secret function! Use =DATEDIF(A2,B2,"Y")&" years"&=DATEDIF(A2,B2,"YM")&" months"&=DATEDIF(A2,B2,"MD")&" days"
Sort by date Sort by votes
See if this works for you
Code: 
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
 
Upvote 0
Another option
Code: 
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
 
Upvote 0
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:
Code: 
[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.
 
Upvote 0
I believe I got it to work now. It appears that
Code: 
.Copy Range ("A1")
does not seem to work; however,
Code: 
.Copy Destination:=[A1]
does. Thoughts? Is that the right syntax?

JayB0730 said:
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:
Code: 
[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.
Click to expand...
 
Upvote 0
Both of those lines are the same (just a different way of righting it), but if that works for you, then go for it.
 
Upvote 0
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?

Code: 
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
 
Last edited:
Upvote 0
If you step through the code using F8, when you get to the Workbooks.add line, check that the data has been filtered correctly.
 
Upvote 0
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.

Code: 
Ws.Range("A2:Y2").AutoFilter 23, Cl.Value
Ws.Range("A2:Y2").AutoFilter 25, Dic.keys
 
Last edited:
Upvote 0
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
 
Upvote 0
You must log in or register to reply here.

Similar threads

M
  • Question Question
VBA code that pulls the data from the workbook to another workbook
Replies
5
Views
456
MMM_84
M
D
  • Question Question
VBA to Populate an Issue Status Cell
Replies
0
Views
381
Desiato34
D
R
  • Solved
VBA Help - Split Data Worksheet with helper sheet into separate workbooks, preserve all formatting and structure and PW protect sheet
Replies
6
Views
351
John_w
J
M
  • Question Question
VBA to change Subtotal string in active worksheet (with sample)
Replies
0
Views
343
MikeL
M
R
  • Question Question
How to update a list tab based on an evolving data tab
Replies
0
Views
457
runderwood10
R

Forum statistics

Threads
1,223,164
Messages
6,170,444
Members
452,326
Latest member
johnshaji

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top