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循环 - 只需对For的整列使用I循环。

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

循环通过自动过滤条件VBA不是从第一个可用结果开始？

1 个答案: