Поиск определенного текста и копирование данных на другой лист

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

В действии