If Condition to create sheets only when Auto filter has data

Question

I have written a code which does the below steps.

1) Loops through a list of products 2) Auto filters the data with each product. 3) Copies and pastes data on to separate worksheets and names it with that product name. 4) Inserts a line at every change in schedule

The only thing I couldn't do it here is to limit separate worksheet creation only for the products available in the source data when auto filtered.

I tried to do this by adding an if condition to add worksheets by product name only if auto filter shows any data but for some reason it is not working.

I would appreciate any help in fixing this problem and clean my code to make it look better and work faster.

Sub runreport()

Dim rRange As Range
Dim Rng As Range

' Open the Source File
Filename = Application.GetOpenFilename()
Workbooks.Open Filename




'Loops through each product type range from the macro spreadsheet.
For Each producttype In ThisWorkbook.Sheets("Schedule").Range("Product")

            ' Filters the sheet with a product code that matches and copy's the active sheet selection
            Workbooks("Source.xlsx").Sheets("Sheet1").Range("A1:G1").AutoFilter Field:=4, Criteria1:=producttype

             Sheets("Sheet1").Select

                Sheets("Sheet1").Select
                Range("A2").Select
                Range(Selection, Selection.End(xlDown)).Select
                Range(Selection, Selection.End(xlToRight)).Select
                Selection.Copy
                'Adds a new workbook
                ActiveWorkbook.Sheets.Add After:=ActiveWorkbook.Sheets(Sheets.Count)
                'Names the worksheet by Prod type descreption doing a vlookup from the spreadsheet
                ActiveSheet.Name = Application.VLookup(producttype, ThisWorkbook.Sheets("Sheet2").Range("A:B"), 2, False)

                'This will paste the filtered data from Source Data to the new sheet that is added
                Range("a2").Select
                ActiveSheet.Paste

                ns = ActiveSheet.Name

                'Copeis the headers to all the new sheets
                Sheets("Sheet1").Select
                Range("A1:BC1").Select
                Selection.Copy
                Sheets(ns).Activate
                Range("a1").Select
                ActiveSheet.Paste
                Columns.AutoFit

                    ' Inserts a blank row for everychange in ID
                    myRow = 3
                    Do Until Cells(myRow, 3) = ""
                    If Cells(myRow, 3) = Cells(myRow - 1, 3) Then
                    myRow = myRow + 1
                    Else
                    Cells(myRow, 1).EntireRow.Insert
                    myRow = myRow + 2
                    End If
                    Loop

Next producttype


End Sub

Answer 1

First, you can check this answer for ways to optimize your vba code

As for your code in its current form, it would be easiest if you select the entire range of your product code data first. Then you can check this range after your filter and determine if all the rows are hidden. See a sample of the code below

Dim productData as Range 

Set productData = Range(Range("A2"), Range("A2").End(xlDown).End(xlToRight))

' Filters the sheet with a product code that matches and copy's the active sheet selection
Workbooks("Source.xlsx").Sheets("Sheet1").Range("A1:G1").AutoFilter _
Field:=4, Criteria1:=producttype

' The error check will skip the creation of a new sheet if the copy failed (i.e. returns a non-zero error number)
On Error Resume Next
' Copies only the visible cells
productData.SpecialCells(xlCellTypeVisible).Copy

If Err.number = 0 then    
    'Adds a new workbook
    ActiveWorkbook.Sheets.Add After:=ActiveWorkbook.Sheets(Sheets.Count)
    ActiveSheet.Name = Application.VLookup(producttype, _
        ThisWorkbook.Sheets("Sheet2").Range("A:B"), 2, False)
    Range("a2").Select
    ActiveSheet.Paste
End If

Answer 2

While you can Range.Offset one row and check if the Range.SpecialCells method with xlCellTypeVisible is Not Nothing, I prefer to use the worksheet's SUBTOTAL function. The SUBTOTAL function discards hidden or filtered rows from its operations so a simple COUNTA (SUBTOTAL subfunction 103) of the cells below the header will tell you if there is anything available.

Sub runreport()

    Dim rRange As Range, rHDR As Range, rVAL As Range, wsn As String
    Dim fn As String, owb As Workbook, twb As Workbook
    Dim i As Long, p As Long, pTYPEs As Variant

    pTYPEs = ThisWorkbook.Sheets("Schedule").Range("Product").Value2

    Set twb = ThisWorkbook

    ' Open the Source File
    fn = Application.GetOpenFilename()
    Set owb = Workbooks.Open(fn)

    With owb
        'is this Workbooks("Source.xlsx")?
    End With

    With Workbooks("Source.xlsx").Worksheets("Sheet1")
        With .Cells(1, 1).CurrentRegion
            'store the header in case it is needed for a new worksheet
            Set rHDR = .Rows(1).Cells
            'reset the the filtered cells
            Set rVAL = Nothing
            For p = LBound(pTYPEs) To UBound(pTYPEs)
                .AutoFilter Field:=4, Criteria1:=pTYPEs(p)
                With .Resize(.Rows.Count - 1, 7).Offset(1, 0) '<~~resize to A:G and move one down off the header row
                    If CBool(Application.Subtotal(103, .Cells)) Then
                        'there are visible cells; do stuff here
                        Set rVAL = .Cells
                        wsn = Application.VLookup(pTYPEs(p), twb.Worksheets("Sheet2").Range("A:B"), 2, False)

                        'if the wsn worksheet doesn't exist, go make one and come back
                        On Error GoTo bm_New_Worksheet
                        With Worksheets(wsn)
                            On Error GoTo bm_Safe_Exit
                            rVAL.Copy Destination:=.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)

                            'when inserting rows, always work from the bottom to the top
                            For i = .Cells(Rows.Count, 3).End(xlUp).Row To 3 Step -1
                                If .Cells(i, 3).Value2 <> .Cells(i - 1, 3).Value2 Then
                                    .Rows(i).Insert
                                End If
                            Next i

                            'autofit the columns
                            For i = .Columns.Count To 1 Step -1
                                .Columns(i).AutoFit
                            Next i

                        End With
                    End If
                End With
            Next p
        End With
    End With

    GoTo bm_Safe_Exit

bm_New_Worksheet:
    On Error GoTo 0
    With Worksheets.Add(after:=Sheets(Sheets.Count))
        .Name = wsn
        rHDR.Copy Destination:=.Cells(1, 1)
    End With
    Resume

bm_Safe_Exit:

End Sub

When a worksheet that is referenced by the wsn string does not exist, the On Error GoTo bm_New_Worksheet runs off and creates one. The Resume brings the code processing right back to the place it errored out.

One caution when using this method is to ensure that you have unique, legal worksheet names returned by your VLOOKUP function.

Answer 3

Try this...

Sub runreport()

Dim rRange As Range
Dim Rng As Range
Dim FiltRows As Integer

' Open the Source File
Filename = Application.GetOpenFilename()
Workbooks.Open Filename




'Loops through each product type range from the macro spreadsheet.
For Each producttype In ThisWorkbook.Sheets("Schedule").Range("Product")

            ' Filters the sheet with a product code that matches and copy's the active sheet selection
            Workbooks("Source.xlsx").Sheets("Sheet1").Range("A1:G1").AutoFilter Field:=4, Criteria1:=producttype
            With Workbooks("Source.xlsx").Sheets("Sheet1")
                FiltRows = .AutoFilter.Range.Rows.SpecialCells(xlCellTypeVisible).Count / .AutoFilter.Range.Columns.Count
            End With
            If FiltRows > 1 Then 'There will always be a header row which is why it needs to be greater than one.
             Sheets("Sheet1").Select

                Sheets("Sheet1").Select
                Range("A2").Select
                Range(Selection, Selection.End(xlDown)).Select
                Range(Selection, Selection.End(xlToRight)).Select
                Selection.Copy
                'Adds a new workbook
                ActiveWorkbook.Sheets.Add After:=ActiveWorkbook.Sheets(Sheets.Count)
                'Names the worksheet by Prod type descreption doing a vlookup from the spreadsheet
                ActiveSheet.Name = Application.VLookup(producttype, ThisWorkbook.Sheets("Sheet2").Range("A:B"), 2, False)

                'This will paste the filtered data from Source Data to the new sheet that is added
                Range("a2").Select
                ActiveSheet.Paste

                ns = ActiveSheet.Name

                'Copeis the headers to all the new sheets
                Sheets("Sheet1").Select
                Range("A1:BC1").Select
                Selection.Copy
                Sheets(ns).Activate
                Range("a1").Select
                ActiveSheet.Paste
                Columns.AutoFit

                    ' Inserts a blank row for everychange in ID
                    myRow = 3
                    Do Until Cells(myRow, 3) = ""
                    If Cells(myRow, 3) = Cells(myRow - 1, 3) Then
                    myRow = myRow + 1
                    Else
                    Cells(myRow, 1).EntireRow.Insert
                    myRow = myRow + 2
                    End If
                    Loop
            End If
Next producttype


End Sub

I would recommend you define more variables than you have it keeps the code cleaner and easier to read as well as eliminates easy errors.
I also recommend always to utilize "option explicit" at the top of every code. It forces defining all variables (when you don't define a variable the program will do it for you (assuming you haven't used option explicit), but excel doesn't always get it correct. Also option explicit helps you avoid typos in variables. Also as a general rule you rarely if ever have to .select anything to do what you need to with vba.

Below is an example of a cleaned up and shortened code which utilized variable definition and instantiation.

Sub runreport()

Dim wb As Workbook
Dim wsSched As Worksheet
Dim wsNew As Worksheet
Dim wbSource As Workbook
Dim wsSource As Worksheet
Dim rRange As Range
Dim producttype As Range
Dim Filename As String
Dim FiltRows As Integer
Dim myRow As Integer

'instantiate Variables
Set wb = ThisWorkbook
Set wsSched = wb.Worksheets("Schedule")

' Open the Source File
Filename = Application.GetOpenFilename()
Set wbSource = Workbooks.Open(Filename)
Set wsSource = wbSource.Worksheets("Sheet1")

'Loops through each product type range from the macro spreadsheet.
For Each producttype In wsSched.Range("Product")
            ' Filters the sheet with a product code that matches and copy's the active sheet selection
            With wsSource
                .AutoFilterMode = False
                .Range("A1:G1").AutoFilter Field:=4, Criteria1:=producttype
                FiltRows = .AutoFilter.Range.Rows.SpecialCells(xlCellTypeVisible).Count / .AutoFilter.Range.Columns.Count
                If FiltRows > 1 Then 'There will always be a header row which is why it needs to be greater than one.
                    'Add new workbook
                    Set wsNew = wb.Sheets.Add(After:=ActiveWorkbook.Sheets(Sheets.Count))
                    'Copy filtered data including header
                    .AutoFilter.Range.SpecialCells(xlCellTypeVisible).Copy
                    'Paste filterd data and header
                    wsNew.Range("A1").PasteSpecial
                    Application.CutCopyMode = False
                    wsNew.Columns.AutoFit
                    'Rename new worksheet
                    wsNew.Name = WorksheetFunction.VLookup(producttype, wb.Worksheets("Sheet2").Range("A:B"), 2, False)

                        ' Inserts a blank row for everychange in ID
                        myRow = 3
                        Do Until Cells(myRow, 3) = ""
                        If Cells(myRow, 3) = Cells(myRow - 1, 3) Then
                        myRow = myRow + 1
                        Else
                        Cells(myRow, 1).EntireRow.Insert
                        myRow = myRow + 2
                        End If
                        Loop
                End If
            End With
Next producttype

End Sub