Question

我有一个工作表，在其中管理某种价目表。它有两张纸看起来像这样的输出纸。

总共有18列。从K到Z的列，其中包含价格表。但是在这些列中，有许多单元格包含No price值而不是$中的价格。

我想一一过滤一列，然后将包含No price的所有行复制到另一张纸上。我已经使用多个if语句编写了一个非常基本的宏，但没有得到所需的输出。有人可以帮我吗？

代码在下面。

Sub FilterNoPrice()
    Dim myRange As Range
    Dim myRow As Variant                '### NOTE THIS CHANGE!
    Sheets("Output").Select

    Set myRange = Range("K3:K10000")

    myRow = Application.Match("No price", myRange, False)

    If Not IsError(myRow) Then
       ActiveSheet.Range("K:K").AutoFilter Field:=1, Criteria1:="No price"
        ' and then select/activate the cell:
        'Application.GoTo Cells(1, myRow)
    Else
        ' The value is not found in the range, so inform you:
        'MsgBox "Not found!"
    End If

    Set myRange = Range("L3:L10000")
    myRow = Application.Match("No price", myRange, False)
    If Not IsError(myRow) Then
       ActiveSheet.Range("L:L").AutoFilter Field:=2, Criteria1:="No price"
        ' and then select/activate the cell:
        'Application.GoTo Cells(1, myRow)
    Else
        ' The value is not found in the range, so inform you:
        'MsgBox "Not found!"
    End If

    Set myRange = Range("M3:M10000")
    myRow = Application.Match("No price", myRange, False)
    If Not IsError(myRow) Then
       ActiveSheet.Range("M:M").AutoFilter Field:=3, Criteria1:="No price"
        ' and then select/activate the cell:
        'Application.GoTo Cells(1, myRow)
    Else
        ' The value is not found in the range, so inform you:
        MsgBox "Not found!"
   End If

    Set myRange = Range("N3:N10000")
    myRow = Application.Match("No price", myRange, False)
    If Not IsError(myRow) Then
       ActiveSheet.Range("N:N").AutoFilter Field:=4, Criteria1:="No price"
        ' and then select/activate the cell:
        'Application.GoTo Cells(1, myRow)
    Else
        ' The value is not found in the range, so inform you:
        MsgBox "Not found!"
   End If


    Set myRange = Range("O3:O10000")
    myRow = Application.Match("No price", myRange, False)
    If Not IsError(myRow) Then
       ActiveSheet.Range("O:O").AutoFilter Field:=5, Criteria1:="No price"
        ' and then select/activate the cell:
        'Application.GoTo Cells(1, myRow)
    Else
        ' The value is not found in the range, so inform you:
        MsgBox "Not found!"
   End If


    Set myRange = Range("P3:P10000")
    myRow = Application.Match("No price", myRange, False)
    If Not IsError(myRow) Then
       ActiveSheet.Range("P:P").AutoFilter Field:=6, Criteria1:="No price"
        ' and then select/activate the cell:
        'Application.GoTo Cells(1, myRow)
    Else
        ' The value is not found in the range, so inform you:
        MsgBox "Not found!"
   End If

    Set myRange = Range("Q3:Q10000")
    myRow = Application.Match("No price", myRange, False)
    If Not IsError(myRow) Then
       ActiveSheet.Range("Q:Q").AutoFilter Field:=7, Criteria1:="No price"
        ' and then select/activate the cell:
        'Application.GoTo Cells(1, myRow)
    Else
        ' The value is not found in the range, so inform you:
        MsgBox "Not found!"
   End If


    Set myRange = Range("R3:R10000")
    myRow = Application.Match("No price", myRange, False)
    If Not IsError(myRow) Then
       ActiveSheet.Range("R:R").AutoFilter Field:=8, Criteria1:="No price"
        ' and then select/activate the cell:
        'Application.GoTo Cells(1, myRow)
    Else
        ' The value is not found in the range, so inform you:
        MsgBox "Not found!"
   End If

    Set myRange = Range("S3:S10000")
    myRow = Application.Match("No price", myRange, False)
    If Not IsError(myRow) Then
       ActiveSheet.Range("S:S").AutoFilter Field:=9, Criteria1:="No price"
        ' and then select/activate the cell:
        'Application.GoTo Cells(1, myRow)
    Else
        ' The value is not found in the range, so inform you:
        MsgBox "Not found!"
   End If


    Set myRange = Range("T3:T10000")
    myRow = Application.Match("No price", myRange, False)
    If Not IsError(myRow) Then
       ActiveSheet.Range("T:T").AutoFilter Field:=10, Criteria1:="No price"
        ' and then select/activate the cell:
        'Application.GoTo Cells(1, myRow)
    Else
        ' The value is not found in the range, so inform you:
        MsgBox "Not found!"
   End If

    Set myRange = Range("U3:U10000")
    myRow = Application.Match("No price", myRange, False)
    If Not IsError(myRow) Then
       ActiveSheet.Range("U:U").AutoFilter Field:=11, Criteria1:="No price"
        ' and then select/activate the cell:
        'Application.GoTo Cells(1, myRow)
    Else
        ' The value is not found in the range, so inform you:
        MsgBox "Not found!"
   End If



   Set myRange = Range("V3:V10000")
    myRow = Application.Match("No price", myRange, False)
    If Not IsError(myRow) Then
       ActiveSheet.Range("V:V").AutoFilter Field:=12, Criteria1:="No price"
        ' and then select/activate the cell:
        'Application.GoTo Cells(1, myRow)
    Else
        ' The value is not found in the range, so inform you:
        MsgBox "Not found!"
   End If

       Set myRange = Range("W3:W10000")
    myRow = Application.Match("No price", myRange, False)
    If Not IsError(myRow) Then
       ActiveSheet.Range("W2:W10000").AutoFilter Field:=13, Criteria1:="No price"
        ' and then select/activate the cell:
        'Application.GoTo Cells(1, myRow)
    Else
        ' The value is not found in the range, so inform you:
        MsgBox "Not found!"
   End If


      Set myRange = Range("X3:X10000")
    myRow = Application.Match("No price", myRange, False)
    If Not IsError(myRow) Then
       ActiveSheet.Range("X:X").AutoFilter Field:=14, Criteria1:="No price"
        ' and then select/activate the cell:
        'Application.GoTo Cells(1, myRow)
    Else
        ' The value is not found in the range, so inform you:
        MsgBox "Not found!"
   End If



      Set myRange = Range("Y3:Y10000")
    myRow = Application.Match("No price", myRange, False)
    If Not IsError(myRow) Then
       ActiveSheet.Range("Y:Y").AutoFilter Field:=15, Criteria1:="No price"
        ' and then select/activate the cell:
        'Application.GoTo Cells(1, myRow)
    Else
        ' The value is not found in the range, so inform you:
        MsgBox "Not found!"
   End If


      Set myRange = Range("Z3:Z10000")
    myRow = Application.Match("No price", myRange, False)
    If Not IsError(myRow) Then
       ActiveSheet.Range("Z:Z").AutoFilter Field:=16, Criteria1:="No price"
        ' and then select/activate the cell:
        'Application.GoTo Cells(1, myRow)
    Else
        ' The value is not found in the range, so inform you:
        MsgBox "Not found!"
   End If

End Sub

Answer 1

正如我在评论中提到的那样，不需要为每一列设置单独的过滤器代码。您只能设置一个范围K:L，然后只需在循环中更改field:=，如下所示

假设您的工作表是这样的

将此代码粘贴到模块中。我已经注释了代码，因此您在理解它时应该不会有问题。但是，如果这样做，那就问一下。

Option Explicit

Sub Sample()
    Dim ws As Worksheet, wsOutput As Worksheet
    Dim lastrow As Long, i As Long
    Dim rng As Range, rngToCopy As Range

    '~~> Change the name of the sheets as applicable
    Set ws = Sheet1
    Set wsOutput = Sheet2

    With ws
        '~~> Find Last Row in the sheet
        If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
            lastrow = .Cells.Find(What:="*", _
                          After:=.Range("A1"), _
                          Lookat:=xlPart, _
                          LookIn:=xlFormulas, _
                          SearchOrder:=xlByRows, _
                          SearchDirection:=xlPrevious, _
                          MatchCase:=False).Row
        Else
            MsgBox "No Data Found"
            Exit Sub
        End If

        '~~> Set your filter range
        Set rng = .Range("K2:Z" & lastrow)

        '~~> Loop through the range
        For i = 1 To rng.Columns.Count
            .AutoFilterMode = False

            '~~> Filter the range and store the filtered range
            '~~> if applicable in a range object
            With rng
                .AutoFilter Field:=i, Criteria1:="No price"

                If rngToCopy Is Nothing Then
                    Set rngToCopy = .Offset(1, 0).SpecialCells(xlCellTypeVisible)
                Else
                    Set rngToCopy = Union(rngToCopy, .Offset(1, 0).SpecialCells(xlCellTypeVisible))
                End If
            End With
        Next i

        .AutoFilterMode = False

        '~~> Clear output sheet and copy data across
        If Not rngToCopy Is Nothing Then
            wsOutput.Cells.Clear
            .Range("K2:Z2").Copy wsOutput.Cells(1, 1) '<~~ Copy Headers
            rngToCopy.Copy wsOutput.Cells(2, 1) '<~~ Copy Filtered Data
        End If
    End With
End Sub

实际操作

搜索特定文本并将数据复制到另一个工作表

1 个答案: