Creating new workbooks with autofiltered data

[imonfiire]

Hi, I have code that filters my data and then copies the visible cells and pastes it into a new workbook and saves it. However, I need to generate multiple workbooks with different criteria (from the filter), so I just reused the same code. Issue is my code works once and generates a report (let's say I filtered for A), but then the second report (supposed to filter for B) will give me the "excel has run out of memory" error. Not sure why that's happening or if my code is bad. Many thanks in advance for any advice you guys may have!

Sub AllReports()

Call First
Call Second


End Sub






Sub First()


Dim LastRow As Integer
With Sheets("Sheet1")
LastRow = .Range("G" & .Rows.Count).End(xlUp).Row


Sheets("Sheet1").Select
ActiveSheet.AutoFilterMode = False
Range("A1:EK1").AutoFilter
'FILTER HERE
ActiveSheet.Range("$A$1:$EK$" & LastRow).AutoFilter field:=7, Criteria1:="FIRST"


Dim newBook As Excel.Workbook
Dim rng As Excel.Range


Set newBook = Workbooks.Add


Set rng = ThisWorkbook.Worksheets("Sheet1").Cells.SpecialCells(xlCellTypeVisible)


rng.Copy newBook.Worksheets("Sheet1").Range("A1")
    
'FILENAME HERE
ActiveWorkbook.SaveAs Filename:="C:\Users\Documents\First.xls"


End With
End Sub


Sub Second()


Dim LastRow As Integer
With Sheets("Sheet1")
LastRow = .Range("G" & .Rows.Count).End(xlUp).Row


Sheets("Sheet1").Select
ActiveSheet.AutoFilterMode = False
Range("A1:EK1").AutoFilter
'FILTER HERE
ActiveSheet.Range("$A$1:$EK$" & LastRow).AutoFilter field:=6, Criteria1:="SECOND"


Dim newBook As Excel.Workbook
Dim rng As Excel.Range


Set newBook = Workbooks.Add


Set rng = ThisWorkbook.Worksheets("Sheet1").Cells.SpecialCells(xlCellTypeVisible)


rng.Copy newBook.Worksheets("Sheet1").Range("A1")
    
'FILENAME HERE
ActiveWorkbook.SaveAs Filename:="C:\Users\Documents\Second.xls"


End With
End Sub

 

[dmt32]

Hi welcome tp the board.

Not tested but see if this does what you want.

Sub CreateReports()
    Dim newBook As Excel.Workbook
    Dim rng As Excel.Range
    Dim LastRow As Long
    Dim i As Integer
    Dim CriteriaArr As Variant
    
    CriteriaArr = Array("Second", "First")
    
    
    For i = LBound(CriteriaArr) To UBound(CriteriaArr)
    
        With ThisWorkbook.Worksheets("Sheet1")
    
            LastRow = .Range("G" & .Rows.Count).End(xlUp).Row
    
             With .Range("A1:EK" & LastRow)
                    .AutoFilter
            
                    'FILTER HERE
                    .AutoFilter field:=6 + i, Criteria1:=CriteriaArr(i)
    
            Set rng = .AutoFilter.Range
        
            End With
        End With
    
        Set rng = rng.SpecialCells(xlCellTypeVisible)
    
        If Not rng Is Nothing Then
        Set newBook = Workbooks.Add(1)
            rng.Copy
            newBook.Worksheets(1).Range("A1").PasteSpecial Paste:=xlPasteValues
            Application.CutCopyMode = False
            newBook.SaveAs Filename:="C:\Users\Documents\" & CriteriaArr(i) & ".xls"
            newBook.Close False
        End If
        
        Set rng = Nothing
        Set newBook = Nothing
        
    Next i
End Sub

Dave

 

[imonfiire]

Thanks Dave! Appreciate the help. I tried your array code but got a "Object Required" error on the Set rng = .AutoFilter.Range

 

[dmt32]

Thanks Dave! Appreciate the help. I tried your array code but got a "Object Required" error on the Set rng = .AutoFilter.Range

Sorry my error.

you need to move that line to sit between the two End With lines in the code:

           End With
            
            Set rng = .AutoFilter.Range


        End With

Dave

 

[imonfiire]

Thanks Dave, that worked perfectly!

 

[dmt32]

Thanks Dave, that worked perfectly!

Most welcome - many thanks for feedback.

Dave