Results 1 to 3 of 3
  1. #1
    Lounger
    Join Date
    Dec 2001
    Posts
    48
    Thanks
    0
    Thanked 0 Times in 0 Posts

    Create Subset Files (2002)

    I have a sorted table. Need to create new files with subsets of rows from table. Attached file shows intent. Created files are to be saved in say, D:. Prefer a VBA solution. Thanking you in advance.

  2. #2
    Uranium Lounger
    Join Date
    Jan 2001
    Location
    South Carolina, USA
    Posts
    7,295
    Thanks
    0
    Thanked 0 Times in 0 Posts

    Re: Create Subset Files (2002)

    See if something like this will do what you want. You did not say how you wanted the files named, so this code will name the files the same as the Type in Column A.

    <pre>Option Explicit
    Public Sub CreateFiles()
    Dim I As Long, J As Long, lLastRow As Long
    Dim oNewWB As Workbook, oOldWB As Workbook
    Set oOldWB = ActiveWorkbook
    lLastRow = Worksheets("Sheet1").Range("A65535").End(xlUp).Row - 1
    I = 1
    With Worksheets("Sheet1")
    Do While I < lLastRow
    J = I
    Do While .Range("A1").Offset(J) = .Range("A1").Offset(J + 1)
    J = J + 1
    Loop
    Set oNewWB = Workbooks.Add
    .Range("A1:B1").Copy Destination:=oNewWB.Worksheets("Sheet1").Range("A1 ")
    .Range(.Range("A1").Offset(I, 0), .Range("B1").Offset(J, 0)).Copy _
    Destination:=oNewWB.Worksheets("Sheet1").Range("A2 ")
    oNewWB.Worksheets("Sheet1").Range("A:B").EntireCol umn.AutoFit
    oNewWB.SaveAs Filename:="D:" & .Range("A1").Offset(I).Value
    oNewWB.Close
    Set oNewWB = Nothing
    I = J + 1
    Loop
    End With
    Set oOldWB = Nothing
    End Sub
    </pre>

    Legare Coleman

  3. #3
    Gold Lounger
    Join Date
    Feb 2001
    Location
    Dublin, Ireland, Republic of
    Posts
    2,697
    Thanks
    1
    Thanked 0 Times in 0 Posts

    Re: Create Subset Files (2002)

    You could also utilise Excel's Advanced Filter to help. It migh prove quicker should you have a large amount of data. Create a range eith a list of the types (A, M, Q etc), set up a criteria range and on a blank worksheet set up an Extract range with the column headings you uwant to extract. The following code should then do all the work for you :

    Sub CreateSubsets()
    Application.ScreenUpdating = False
    Dim oCell As Range, strType As String
    For Each oCell In [Types]
    strType = oCell.Value
    [Criteria].Cells(2) = strType
    Sheets("Sheet1").Columns("A:B").AdvancedFilter _
    Action:=xlFilterCopy, _
    CriteriaRange:=[Criteria], _
    CopyToRange:=[Extract], _
    Unique:=False
    Sheets("Extract").Copy
    ActiveSheet.Name = ActiveSheet.Name & strType
    With ActiveWorkbook
    .SaveAs "D:" & strType & ".xls"
    .Close
    End With
    Next
    Application.ScreenUpdating = True
    End Sub

    I am attaching a copy of your file with everything set up.

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •