Results 1 to 4 of 4
  1. #1
    2 Star Lounger
    Join Date
    Jun 2001
    Location
    Vancouver, BC
    Posts
    100
    Thanks
    0
    Thanked 0 Times in 0 Posts

    Macro to split out spreadsheet

    I was wondering if anyone knew of a macro to split out a spreadsheet based on the data in one column. I work with a weekly file of about 10,000 records of delivery addresses for a product that is delivered by 13 distributors. Each week I have to split up the file, keeping my master file and sending 13 files out - one to each distributor. This is a laborious process.

    The distributors would be in column A (see sample sheet). The number of records for each distributor varies from week to week, so I never know in advance how many records each distributor will have. Basically, I'd just like to have a macro that would take the master file, then create 13 new files, each one containing just one distributor's records.

    Any ideas?

    Thanks!
    Attached Files Attached Files

  2. #2
    WS Lounge VIP sdckapr's Avatar
    Join Date
    Jul 2002
    Location
    Pittsburgh, Pennsylvania, USA
    Posts
    11,225
    Thanks
    14
    Thanked 342 Times in 335 Posts
    How about this code? It extracts each unique distributor out into a new worksheet in the workbook.
    Code:
    Option Explicit
    Sub ExtractAllAutofilter()
      Dim wks As Worksheet
      Dim wksNew As Worksheet
      Dim wksPT As Worksheet
      Dim PT As PivotTable
      Dim rPT As Range
      Dim rCell As Range
      Dim iCol As Integer
      Dim sHeader As String
      Dim x As Integer
      On Error GoTo Errhandler
      Application.ScreenUpdating = False
      
      iCol = 1 'Filter all on Col A
      Set wks = ActiveSheet
      With wks
        If Not .AutoFilterMode Then
          .Range("a1").AutoFilter
        End If
        If .FilterMode Then .ShowAllData
      
        Set PT = .PivotTableWizard _
          (SourceType:=xlDatabase, _
          SourceData:=.Range("a1").CurrentRegion, _
          TableDestination:="", _
          TableName:="PivotTable1")
        sHeader = .Cells(1, iCol)
        With PT
          .AddFields RowFields:=sHeader
          .PivotFields(sHeader).Orientation = xlDataField
          .ColumnGrand = False
        End With
        Set wksPT = ActiveSheet
        With wksPT
          Set rPT = .Range(.Range("A3"), _
            .Cells(.Rows.Count, 1).End(xlUp))
        End With
        x = 0
        For Each rCell In rPT
          .Range("a1").AutoFilter Field:=iCol, _
            Criteria1:=rCell.Value
          Set wksNew = Worksheets.Add
          With wksNew
            wks.Cells.Copy .Range("A1")
            .Name = rCell.Value
            .Columns.AutoFit
            x = x + 1
          End With
        Next
        .ShowAllData
      End With
      Application.DisplayAlerts = False
      wksPT.Delete
      MsgBox x & " New Worksheets Created"
    ExitHandler:
      Application.DisplayAlerts = True
      Application.ScreenUpdating = True
      Set rCell = Nothing
      Set rPT = Nothing
      Set PT = Nothing
      Set wks = Nothing
      Set wksNew = Nothing
      Set wksPT = Nothing
      Exit Sub
      
    Errhandler:
      MsgBox Err.Number & ":" & Err.Description
      Resume ExitHandler
    End Sub
    You could combine it with the code from Ron deBruin at http://www.rondebruin.nl/win/s1/outlook/mail.htm to mail them using outlook.

    Steve

  3. #3
    WS Lounge VIP sdckapr's Avatar
    Join Date
    Jul 2002
    Location
    Pittsburgh, Pennsylvania, USA
    Posts
    11,225
    Thanks
    14
    Thanked 342 Times in 335 Posts
    I did not read closely enough. The code I wrote, creates new worksheets within the workboo. This code creates new workbooks each with 1 sheet.

    Steve
    Code:
    Option Explicit
    Sub ExtractAllAutofilter()
      Dim wkb As Workbook
      Dim wks As Worksheet
      Dim wksNew As Worksheet
      Dim wksPT As Worksheet
      Dim PT As PivotTable
      Dim rPT As Range
      Dim rCell As Range
      Dim iCol As Integer
      Dim sHeader As String
      Dim x As Integer
      On Error GoTo Errhandler
      Application.ScreenUpdating = False
      
      iCol = 1 'Filter all on Col A
      Set wks = ActiveSheet
      With wks
        If Not .AutoFilterMode Then
          .Range("a1").AutoFilter
        End If
        If .FilterMode Then .ShowAllData
      
        Set PT = .PivotTableWizard _
          (SourceType:=xlDatabase, _
          SourceData:=.Range("a1").CurrentRegion, _
          TableDestination:="", _
          TableName:="PivotTable1")
        sHeader = .Cells(1, iCol)
        With PT
          .AddFields RowFields:=sHeader
          .PivotFields(sHeader).Orientation = xlDataField
          .ColumnGrand = False
        End With
        Set wksPT = ActiveSheet
        With wksPT
          Set rPT = .Range(.Range("A3"), _
            .Cells(.Rows.Count, 1).End(xlUp))
        End With
        x = 0
        For Each rCell In rPT
          .Range("a1").AutoFilter Field:=iCol, _
            Criteria1:=rCell.Value
          Set wkb = Workbooks.Add(xlWBATWorksheet)
          Set wksNew = wkb.Worksheets(1)
          With wksNew
            wks.Cells.Copy .Range("A1")
            .Name = rCell.Value
            .Columns.AutoFit
            x = x + 1
          End With
        Next
        .ShowAllData
      End With
      Application.DisplayAlerts = False
      wksPT.Delete
      MsgBox x & " Workbooks Created"
    ExitHandler:
      Application.DisplayAlerts = True
      Application.ScreenUpdating = True
      Set rCell = Nothing
      Set rPT = Nothing
      Set PT = Nothing
      Set wks = Nothing
      Set wksNew = Nothing
      Set wksPT = Nothing
      Set wkb = Nothing
      Exit Sub
      
    Errhandler:
      MsgBox Err.Number & ":" & Err.Description
      Resume ExitHandler
    End Sub

  4. #4
    Gold Lounger Maudibe's Avatar
    Join Date
    Aug 2010
    Location
    Pa, USA
    Posts
    2,633
    Thanks
    115
    Thanked 647 Times in 590 Posts
    Here is a different approach from the one used in the above post. It will filter the data using the unique distributor criteria then create a workbook for each. All the created workbooks are closed.

    HTH
    Maud

    Code:
    Public Sub DestinationFilter()
    Application.ScreenUpdating = False
    'DECLARE AND SET VARIABLES
    Dim rng As Range
    Dim FilterArray()
    Dim Distributor As Range
    Set CurrentWb = ActiveWorkbook
    LastRow1 = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
    Set rng = Range(Cells(2, 1), Cells(LastRow1, 1))
    Set rng2 = Range("A1:E" & LastRow1)
    '-----------------------------------------------
    'GET LIST OF FILTER CRITERIA
    rng.Copy
    [f2].Select
    ActiveSheet.Paste
    Selection.RemoveDuplicates Columns:=1, Header:=xlNo
    LastRow6 = ActiveSheet.Cells(Rows.Count, 6).End(xlUp).Row
    '-----------------------------------------------
    'CREATE NEW WORKBOOK AND COPY FILTERED DATA
    With NewWb
    For I = 2 To LastRow6
    WbName = Cells(I, 6).Value
    rng2.Select
    Selection.AutoFilter
    rng2.AutoFilter field:=1, Criteria1:=Cells(I, 6).Value
    rng2.SpecialCells(xlCellTypeVisible).Copy
    Set NewWb = Workbooks.Add(xlWBATWorksheet)
    NewWb.Activate
    ActiveSheet.Paste
    [a2].Select
    ActiveWorkbook.SaveAs Filename:="C:\Users\Maudibe\Desktop\" & WbName & ".xlsx"
    Set NewWb = Nothing
    ActiveWorkbook.Close
    CurrentWb.Activate
    Selection.AutoFilter
    [a1].Select
    Next I
    Range(Cells(2, 6), Cells(LastRow6, 6)).ClearContents
    End With
    Attached Files Attached Files
    Last edited by Maudibe; 2013-10-30 at 20:32.

Posting Permissions

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