如果条件仅在自动过滤器具有数据时创建工作表-IfConditiontocreatesheetsonlywhenAutofilterhasdata

1  

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.

虽然你可以Range.Offset一行并检查带有xlCellTypeVisible的Range.SpecialCells方法是否为Nothing，我更喜欢使用工作表的SUBTOTAL函数。 SUBTOTAL函数从其操作中丢弃隐藏或过滤的行，因此标题下方单元格的简单COUNTA（SUBTOTAL子函数103）将告诉您是否有任何可用的东西。

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.

当wsn字符串引用的工作表不存在时，On Error GoTo bm_New_Worksheet将运行并创建一个。 Resume将代码处理权限带回到它出错的地方。

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

使用此方法时的一个注意事项是确保您具有VLOOKUP函数返回的唯一合法工作表名称。

2  

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.

我建议你定义更多的变量而不是保持代码更清晰，更容易阅读以及消除容易出错的错误。我还建议始终在每个代码的顶部使用“option explicit”。它强制定义所有变量（当你没有定义一个变量时，程序会为你做这个（假设你没有使用选项显式），但是excel并不总是让它正确。另外，显式选项可以帮助你避免拼写错误变量。另外作为一般规则，你很少必须选择任何东西来做你需要用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

2  

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

首先，您可以查看此答案，了解优化vba代码的方法

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