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

Question

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

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

Answer 1

试试这个......

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

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

Answer 2

首先，您可以查看this answer有关优化vba代码的方法

对于当前形式的代码，如果您首先选择整个产品代码数据范围，那将是最简单的。然后，您可以在过滤器后检查此范围，并确定是否隐藏了所有行。请参阅以下代码示例

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 3

虽然您可以Range.Offset排一行并检查Range.SpecialCells method xlCellTypeVisible Not Nothing是否为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 ，但我更喜欢使用工作表SUBTOTAL function 。 SUBTOTAL函数从其操作中丢弃隐藏或过滤的行，因此标题下方单元格的简单COUNTA（SUBTOTAL子函数 103 ）将告诉您是否有可用的内容。

wsn

当On Error GoTo bm_New_Worksheet字符串引用的工作表不存在时，Resume会运行并创建一个。 class freedict(dict): # called when trying to read a missing key def __missing__(self, key): self[key] = freedict() return self[key] # called during attribute access # note that this invokes __missing__ above def __getattr__(self, key): return self[key] # called during attribute assignment def __setattr__(self, key, value): self[key] = value 将代码处理权限带回到错误的位置。

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