循环通过 Autofilter Criteria VBA 不是从第一个可用结果开始？

Question

This script is used to filter column I data, copy it and move it to a new worksheet based on the first visible cell in I2 (header is I1). Afterwards, I would want to Loop it to go through the rest of the autofilter criteria without actually referencing anything, just running through the list. It seems to be working but it unselects all the data in Column I and doesn't name the sheet properly because the data results in blank rows. Can anyone help me? 

我只需要代码即可：

按列 I（经理）自动筛选，选择所有单元格，创建新工作表，将过滤后的经理数据从原始数据粘贴到该新工作表中，根据 I 列中的第一个可见单元格值（经理名称）命名工作表，然后循环通过过滤器列表的其余部分，而不必引用经理名称，只是一个 Next 类型的循环功能，直到整个列表已经运行。

   Sub Format()



   Set My_Range = Worksheets("Sheet1").Range("A1:I" & LastRow(Worksheets("Sheet1")))
   Set Name = FirstVisibleValue(ActiveSheet, 2, 9)

Cells.Select


 Do


    'Filter and set the filter field and the filter criteria :
    My_Range.AutoFilter Field:=9, Criteria1:=ActiveCell.Value



    'Add a new Worksheet
    Set WSNew = Worksheets.Add(After:=Sheets("Sheet1"))

    WSNew.Name = Name


        'Copy/paste the visible data to the new worksheet
        My_Range.Parent.AutoFilter.Range.Copy

        With WSNew.Range("A1")

            .PasteSpecial xlPasteValues
            Cells.Select
        End With





    'Close AutoFilter
    My_Range.Parent.AutoFilterMode = False

    'Restore ScreenUpdating, Calculation, EnableEvents, ....
    My_Range.Parent.Select
    ActiveWindow.View = ViewMode
    If Not WSNew Is Nothing Then WSNew.Select
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = CalcMode
    End With

Loop

End Sub


Function LastRow(sh As Worksheet)
    On Error Resume Next
    LastRow = sh.Cells.Find(What:="*", _
                            After:=sh.Range("A1"), _
                            Lookat:=xlPart, _
                            LookIn:=xlValues, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Row
    On Error GoTo 0
End Function

Answer 1

试试这个 - 减少很多不必要的东西并清理一下。为了确保我们还没有该经理的工作表，我们使用 UDF WorksheetExists()。

我也尽量避免 Do/Loop 循环 - 只需对 I 的整个列使用 For 循环。

Option Explicit
Sub Format()

Dim sht As Worksheet, WSNew As Worksheet
Dim My_Range As Range
Dim i As Long, lastrow As Long

Set sht = ThisWorkbook.Worksheets("Sheet1")
lastrow = sht.Cells(sht.Rows.Count, "I").End(xlUp).Row
Set My_Range = sht.Range("A1:I" & lastrow)

For i = 2 To lastrow

    If WorksheetExists(sht.Range("I" & i).Value) = False Then

        Set WSNew = Worksheets.Add(After:=Sheets("Sheet1"))
        WSNew.Name = sht.Range("I" & i).Value

        My_Range.AutoFilter Field:=9, Criteria1:=sht.Range("I" & i).Value

        My_Range.Parent.AutoFilter.Range.Copy
        WSNew.Range("A1").PasteSpecial xlPasteValues

    End If

Next i

My_Range.Parent.AutoFilterMode = False
Application.CutCopyMode = False
End Sub
Function WorksheetExists(sName As String) As Boolean
    WorksheetExists = Evaluate("ISREF('" & sName & "'!A1)")
End Function