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

我编写了一个执行以下步骤的代码.

1)循环浏览产品列表
2)自动过滤每个产品的数据.
3)将数据复制并粘贴到单独的工作表上,并使用该产品名称命名.
4)在计划的每次更改时插入一行

我在这里唯一不能做的就是在自动过滤时仅为源数据中可用的产品限制单独的工作表创建.

我试图通过添加if条件来按产品名称添加工作表仅在自动过滤器显示任何数据但由于某种原因它不起作用时才这样做.

我很感激任何帮助解决这个问题并清理我的代码,使其看起来更好,工作更快.

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
最佳答案
虽然你可以Range.Offset一行并检查Range.SpecialCells methodxlCellTypeVisible是否为Nothing,但我更喜欢使用工作表的SUBTOTAL function.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

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

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

转载注明原文:excel-vba – 如果条件仅在自动过滤器具有数据时创建工作表 - 代码日志