If the "Condition" create sheets only when the "Autofilter" has data

Question

I wrote code that takes the following steps.

1) Scrolls the list of products 2) Autofilter data with each product. 3) Copy and paste the data into separate sheets and name them with the name of this product. 4) Inserts a row each time the graph is changed

The only thing I could not do here was to limit the creation of a separate sheet only for products available in the source data during automatic filtering.

I tried to do this by adding an if condition to add sheets by product name only if the automatic filter shows any data, but for some reason it does not work.

I would appreciate any help in fixing this problem and cleaning my code so that it looks better and works 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 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

As long as you have Range.Offset one line and check if the Range.SpecialCells method is with xlCellTypeVisible Not Nothing , I prefer to use the SUBTOTAL worksheet . The SUBTOTAL function discards hidden or filtered rows from its operations, so a simple COUNTA (SUBTOTAL subfunction 103 ) cell under the heading will tell you if there is anything.

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

, wsn, , On Error GoTo bm_New_Worksheet . Resume , .

, , , VLOOKUP.

Answer 2

...

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 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

, , , .
" " . ( , ( ), excel . . , , - . -, vba.

, .

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 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

Answer 3

-, vba

As for your code in its current form, this would be easiest if you first select the entire range of product code data. You can then check this range after the filter and determine if all rows are hidden. See code example 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 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