Need To Create Many Workbooks Based On Original

LearningVBA

New Member
Joined
Sep 16, 2006
Messages
14
I've had a look through various posts on this forum and am unable to find what I'm after (perhaps I'm doing the search wrong) so have decided to ask a question.

My current workbook holds 20 worksheets (some are called Log, Report1, Report2, Records and FilterData). In the sheet called Records I have a large amount of data (43252 records), the identifier being in column C. I'm filtering on column C and then copying and pasting into a sheet called FilterData.

What I would like to do is automate this process so that:-

1. The data is filtered copied/pasted into the FilterData sheet.
2. A new workbook is created with the sheets called Log, Report1, Report2 and FilterData with the data from the original file.
3. The new file to be saved with the name from cell C2 of the FilterData sheet.
4. The process to be repeated untill all records have been filtered.

Hope someone can assist this learner?
 

Excel Facts

Pivot Table Drill Down
Double-click any number in a pivot table to create a new report showing all detail rows that make up that number
Hi LearningVBA,

How many different records are there -- by that, I mean how many workbooks will you be creating?

Also, if I get this right, you want to duplicate sheets 1 to 19 and create a different FilterData for each book -- is that correct?

Where will you be storing these files? Same folder as the original, or a different folder? And how big is the file? If it's (say) 10 Mb and you need to create 75 new files, that's 750 Mb of disk space. Do that a few times and you will possibly run into storage problems.

In concept, you would do something like:

1. Determine how many items need filtering -- Advanced filter to create a unique list
2. Run down that list, repeating the following:
a. Clear FilterData
b. Autofilter using each item as the criteria
c. Copy and paste to FilterData
d. Save As (FilterItem.xls), changing to suit.

What you ask is certainly doable, just wondering if it's the best approach long-term.

Denis
 
Upvote 0
This code will create the replicated files:
Code:
Sub FilterSteps()
    Dim Rw As Long
    Dim c As Range
    Dim Wsh As Worksheet
    Dim sFilter As String
    Dim sPath As String
    
    'determine how many rows, initialise
    Sheets("Records").Activate
    Rw = Range("C65536").End(xlUp).Row
    Set Wsh = Sheets("FilterData")
    sPath = ActiveWorkbook.Path & "\"
    
    'grab a list of unique items for filtering
    Range("C1:C" & Rw).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range( _
        "T1"), Unique:=True
    
    'set up an autofilter, run through list
    Range("A1").CurrentRegion.AutoFilter
    For Each c In Range("T2:T" & Range("T65536").End(xlUp).Row)
        sFilter = c.Value
        Range("A1").CurrentRegion.AutoFilter Field:=3, Criteria1:=sFilter
        Wsh.Cells.ClearContents
        Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy _
            Destination:=Wsh2.Range("A1")
        ActiveWorkbook.SaveAs Filename:=sPath & sFilter & ".xls"
    Next c
End Sub
Denis
 
Upvote 0
SydneyGeek

Here are the answers to your earlier questions:-

How many different records are there -- by that, I mean how many workbooks will you be creating?

Anything between 75 and 100

Also, if I get this right, you want to duplicate sheets 1 to 19 and create a different FilterData for each book -- is that correct?

Partly, I need just the four sheets (Log, Report1, Report2 and FilterData) in the new workbook with the filtered data in.

Where will you be storing these files? Same folder as the original, or a different folder? And how big is the file?

Ideally in the same folder and I would anticapte the files being a bout 1mb in size.

I've tried using your code and keep getting stuck at
Code:
Range("C1:C" & Rw).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range( _
        "T1"), Unique:=True

Comes up with error 'run-time error 1004' No list was found.

Hope you are able to assist further
 
Upvote 0
This is the code that I'm currently using, could someone assist in tidying it up a bit?

Code:
Dim c As Range
Dim sFilter As String
    
    Sheets("Data").Select
    Columns("A:E").Select
    Range("A1:A6").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("H1" _
        ), Unique:=True
        
        
    Range("A1").CurrentRegion.AutoFilter
    For Each c In Range("H2:H" & Range("H65536").End(xlUp).Row)
        sFilter = c.Value
        Sheets("Data").Select
        Range("A1").CurrentRegion.AutoFilter Field:=3, Criteria1:=sFilter
    
    Selection.Copy
    
    Sheets("Filter").Select
    Range("A1").Select
    ActiveSheet.Paste
    
    Sheets("Data").Select
    Selection.AutoFilter
    
   Sheets(Array("Filter", "Data")).Select
   Sheets("Filter").Activate
   Sheets(Array("Filter", "Data")).Copy
    
    


    Next c
 
Upvote 0
Hi LearningVBA,

This version will filter based on the code you provided. I have adjusted it to:
1. Filter on Column A, which is what your code did
2. Create new workbooks with the 4 sheets you wanted
Code:
Sub FilterSteps_2()
    Dim Rw As Long
    Dim c As Range
    Dim Wsh As Worksheet
    Dim sFilter As String
    Dim sPath As String
    
    'determine how many rows, initialise
    Sheets("Data").Activate
    Rw = Range("A65536").End(xlUp).Row
    Set Wsh = Sheets("FilterData")
    sPath = ActiveWorkbook.Path & "\"
    
    'grab a list of unique items for filtering
    Range("A1:A" & Rw).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range( _
        "H1"), Unique:=True
    
    'set up an autofilter, run through list
    Range("A1").CurrentRegion.AutoFilter
    For Each c In Range("H2:H" & Range("H65536").End(xlUp).Row)
        sFilter = c.Value
        Sheets("Data").Activate
        Range("A1").CurrentRegion.AutoFilter Field:=1, Criteria1:=sFilter
        Wsh.Cells.ClearContents
        Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy _
            Destination:=Wsh.Range("A1")
        'copy 4 sheets, save as file named after the filter
        Sheets(Array("Log", "Report1", "Report2", "FilterData")).Select
        Sheets("Log").Activate
        Sheets(Array("Log", "Report1", "Report2", "FilterData")).Copy
        ActiveWorkbook.SaveAs Filename:=sPath & sFilter & ".xls"
        ActiveWindow.Close
    Next c
End Sub
Denis
 
Upvote 0
I'm using the last piece of code as supplied by SydneyGeek, which I've just discovered has a problem.

On the original four worksheets, there are some conditional formats which are not being carried across to the newly created workbooks. Could someone please advise how this can be achieved.
 
Upvote 0
Try something like this.
Code:
Sub DistributeRows()
Dim wbNew As Workbook
Dim wsData As Worksheet
Dim wsCrit As Worksheet
Dim wsNew As Worksheet
Dim rngCrit As Range
Dim LastRow As Long
    
    Set wsData = Worksheets("Records")
    Set wsCrit = Worksheets.Add
    
    LastRow = wsData.Range("A" & Rows.Count).End(xlUp).Row
    
    wsData.Range("C1:C" & LastRow).AdvancedFilter action:=xlFilterCopy, CopyToRange:=wsCrit.Range("A1"), Unique:=True
    
    Set rngCrit = wsCrit.Range("A2")
    While rngCrit.Value <> ""
        Set wsNew = Worksheets.Add
        wsData.Range("A1:E" & LastRow).AdvancedFilter action:=xlFilterCopy, CriteriaRange:=rngCrit.Offset(-1).Resize(2), CopyToRange:=wsNew.Range("A1"), Unique:=True
        wsNew.Name = rngCrit
        wsNew.Copy
        Set wbNew = ActiveWorkbook
        wbNew.Worksheets(1).Name = "FilterData"

        wbNew.SaveAs ThisWorkbook.Path & "\" & rngCrit
        wbNew.Close SaveChanges:=True
        Application.DisplayAlerts = False
        wsNew.Delete
        rngCrit.EntireRow.Delete
        Set rngCrit = wsCrit.Range("A2")
    Wend
    
    wsCrit.Delete
    Application.DisplayAlerts = True
End Sub
 
Upvote 0

Forum statistics

Threads
1,213,546
Messages
6,114,251
Members
448,556
Latest member
peterhess2002

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