Autofilter and create new workbook loop

[twmills]

Hello,

In the attached spreadsheet I'm looking to filter for each value in column B (DTCC #) in the Cost Basis tab. Then create a separate workbook based on what is visible when filtered. Then repeat this process for each different DTCC # that's listed.

I started off creating code that copies all the DTCC numbers and pasting them to the DTCC List tab. Then it'll remove the duplicates to reveal each unique DTCC number in the table. Then I imagine using some sort of loop formula with an AutoFilter code can be created to filter each DTCC number one at a time. Creating a separate workbook for each filtered DTCC number as the loop occurs. In the VBA screen - module1 - I started building the code. Got stuck on the AutoFilter criteria that's referencing the DTCC List tab.

Basically, I'm looking to create a separate workbook for each number listed after the DTCC_List macro is triggered. In this scenario, there are 12 different DTCC numbers in the Cost Basis tab. I would like a separate workbook created for each of the 12 numbers, and it's corresponding lines that are visible when filtered.

Thanks so much as always. You guys (and girls) have always been a huge help.

[georgiboy]

Maybe give the below a try, it saves the 12 workbooks in the same location as the workbook with the code. The workbook with the code needs to be saved somewhere, it won't work in an unsaved workbook.

Sub test()    
    Dim rng As Range, wbDest As Workbook, wsDest As Worksheet, wsCbasis As Worksheet
    Dim DTCCstr As Variant, var As Variant, DTCCcol As New Collection, x As Long
    
    With Application
        .EnableAnimations = False
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With
    
    Set wsCbasis = Sheets("Cost Basis")
    With wsCbasis
        var = .Range("B2:B" & .Range("B" & Rows.Count).End(xlUp).Row)
        
        For x = 0 To UBound(var)
            On Error Resume Next
                DTCCcol.Add var(x, 1), CStr(var(x, 1))
            On Error GoTo 0
        Next x
        
        If Not .AutoFilterMode Then .Range("A1").AutoFilter
        Set rng = .UsedRange
        
        For Each DTCCstr In DTCCcol
            rng.AutoFilter 2, DTCCstr
            rng.SpecialCells(12).Copy
            Set wbDest = Workbooks.Add
            Set wsDest = wbDest.Sheets(1)
            With wsDest.Range("A1")
                .PasteSpecial 8
                .PasteSpecial 12
                .PasteSpecial -4122
            End With
            Application.CutCopyMode = False
            wbDest.SaveAs ThisWorkbook.Path & "/" & DTCCstr & ".xlsx"
            wbDest.Close
        Next DTCCstr
        rng.AutoFilter
    End With
    
    With Application
        .EnableAnimations = True
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With
End Sub

Hope this helps

[snb]

Advancedfilter has been designed for this.
First create an extra sheet, sheet1.

Sub M_snb()
  Sheet3.Cells(1).CurrentRegion.Clear
  Sheet2.UsedRange.Columns(2).AdvancedFilter 2, , Sheet3.Cells(1), True
   
  sn = Sheet3.Cells(1).CurrentRegion
  For j = 2 To UBound(sn)
    Sheet3.Cells(1, 4).Resize(2) = Application.Transpose(Array(sn(1, 1), sn(j, 1)))
    Sheet2.UsedRange.AdvancedFilter 2, Sheet3.Range("D1:D2"), Sheet1.Cells(1)
    Sheet1.Copy
    With ActiveWorkbook
      .SaveAs thisworkbook.path & "\" & sn(j, 1) & ".xlsx", 51
      .Close
    End With
    Sheet1.Cells.Clear
  Next
End Sub

[twmills]

Maybe give the below a try, it saves the 12 workbooks in the same location as the workbook with the code. The workbook with the code needs to be saved somewhere, it won't work in an unsaved workbook.

Sub test()    
    Dim rng As Range, wbDest As Workbook, wsDest As Worksheet, wsCbasis As Worksheet
    Dim DTCCstr As Variant, var As Variant, DTCCcol As New Collection, x As Long
    
    With Application
        .EnableAnimations = False
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With
    
    Set wsCbasis = Sheets("Cost Basis")
    With wsCbasis
        var = .Range("B2:B" & .Range("B" & Rows.Count).End(xlUp).Row)
        
        For x = 0 To UBound(var)
            On Error Resume Next
                DTCCcol.Add var(x, 1), CStr(var(x, 1))
            On Error GoTo 0
        Next x
        
        If Not .AutoFilterMode Then .Range("A1").AutoFilter
        Set rng = .UsedRange
        
        For Each DTCCstr In DTCCcol
            rng.AutoFilter 2, DTCCstr
            rng.SpecialCells(12).Copy
            Set wbDest = Workbooks.Add
            Set wsDest = wbDest.Sheets(1)
            With wsDest.Range("A1")
                .PasteSpecial 8
                .PasteSpecial 12
                .PasteSpecial -4122
            End With
            Application.CutCopyMode = False
            wbDest.SaveAs ThisWorkbook.Path & "/" & DTCCstr & ".xlsx"
            wbDest.Close
        Next DTCCstr
        rng.AutoFilter
    End With
    
    With Application
        .EnableAnimations = True
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With
End Sub

Hope this helps

Yes, this works great. Thank you so much!