Create Multiple XLS files from 1 "master" dbase ex

kwagner1

Active Member
Joined
Jun 10, 2003
Messages
445
I have 1 "master" sheet that contains all my Test Script records from a database dump - about 6,000 in all (MS-Query creates the sheet data - records are sorted by colA). I want to scroll through the master list of all the records and based on a col A value change (script name) create an Excel file (in the current directory using the script name from col A as the file name). It should contain all the records that were in the range of the script name.
Example, if my data dump consisted of 250 records, (25 unique script names in col A, and each script name covers 10 rows (10 steps in each script) then I want to end up with 25 ".xls" files in the "current" directory (each .xls file will only contain the 10 records for that particular script name - which is also the same name of the .xls file) - i hope i explained that clearly....

Example Psuedo code:
For I = 1 to numberOfRecords
if aI <> aI+1 then create new .xls file with the name value in COL aI
else next I
 

Excel Facts

Copy PDF to Excel
Select data in PDF. Paste to Microsoft Word. Copy from Word and paste to Excel.

kwagner1

Active Member
Joined
Jun 10, 2003
Messages
445
i've made a little progress... I've been able to use code to insert a blank row when my A1 (test script name) value changes - thus resulting in a "CurrentRegion" for each test script.

My question now is: - is there a way to loop through and create a seperate ".xls" file for each CurrentRegion in my "master" spreadsheet?
 

kwagner1

Active Member
Joined
Jun 10, 2003
Messages
445
i think i got it folks... here's the code i'm using - 1 MINOR problem.... i only want to save (as the new .xls file) the new sheet that i create. Each file i create gets saved with both sheets (via the "saveas") - When i do the "Sheets(2).SaveAs the entire workbook is saved as the new file - rather than just sheet-2. How do i save just the new sheet-2 only??

Code:
Application.ScreenUpdating = False
Application.DisplayAlerts = False
    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(1).Activate
    Rw = Range("A65536").End(xlUp).Row
    Set Wsh = Sheets(2)
    sPath = ActiveWorkbook.Path & "\"
    
    'grab a list of unique items for filtering - save it in col Z
    Range("A1:A" & Rw).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range( _
        "Z1"), Unique:=True
    
    'set up an autofilter, run through list
    Range("A1").CurrentRegion.AutoFilter
    For Each c In Range("Z2:Z" & Range("Z65536").End(xlUp).Row)
        sFilter = c.Value
        Sheets(1).Activate
        Range("A1").CurrentRegion.AutoFilter Field:=1, Criteria1:=sFilter
        Wsh.Cells.ClearContents  ' clear out sheet 2 before geting data to save
        Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy _
            Destination:=Wsh.Range("A1")
      ' remove col Z from sheet2 (temp column for filter values)
      Sheets(2).Range("z:z").Delete
      Sheets(2).SaveAs Filename:=sPath & sFilter & ".xls"  (<=== HOW DO I SAVE JUST THE NEW SHEET ONLY??)
    Next c
    
    MsgBox "XLS Done"
End Sub
[/code]
 

Norie

Well-known Member
Joined
Apr 28, 2004
Messages
76,300
Office Version
  1. 365
Platform
  1. Windows
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("Master (2)") ' change sheet name accordingly
    Set wsCrit = Worksheets.Add
    
    LastRow = wsData.Range("A" & Rows.Count).End(xlUp).Row
    
    wsData.Range("A1:A" & 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.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
 

Forum statistics

Threads
1,136,269
Messages
5,674,743
Members
419,525
Latest member
helensesc

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
Top