excel - If 条件仅当自动过滤器有数据时创建工作表

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

我建议您定义比现有变量更多的变量，这样可以使代码更干净、更易于阅读，并消除简单的错误。
我还建议始终在每个代码的顶部使用“显式选项”。它强制定义所有变量(当你没有定义变量时，程序会为你做这件事(假设你没有使用选项显式)，但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'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