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!