Create Multiple XLS files from 1 "master" dbase ex

[kwagner1]

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

 

[kwagner1]

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]

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??

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]

Try something like this.

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