Найти ячейку, содержащую текст в столбце и НЕ содержащую определенного слова в первых 6 символах строки

Question

Я ищу столбец для ячейки, которая содержит текст и не содержит слова «кошка» в первых 6 символах (необходимо вводить без учета регистра).Это тогда обрежет весь этот ряд на другой лист.Невозможно заставить код работать без ошибок компиляции.код ниже, прежде чем я пытаюсь изменить его.Я не знаю, как его кодировать, чтобы посмотреть первые 6 символов.

пробовал instr & iserror, но я думаю, что мой существующий код просто нуждается в небольшом изменении, которое ускользает от меня.

Sub CATDEFECTS()

UsdRws = Range("C" & Rows.Count).End(xlUp).Row

For i = UsdRws To 2 Step -1
        If Range("C" & i).Value Like "<>""" And Range("c" & i).Value Like "CAT" Then
            Rows(i).Cut Sheets("AWP DEFECTS").Range("A" & rows.Count).End(xlUp).Offset(1)
            Rows(i).Delete
        End If
        Next i

End Sub

Answer 1

Если cat находится в пределах первых 6 символов, то InStr сообщит, что его позиция меньше 5.

Sub CATDEFECTS()
    dim UsdRws  as long, pos as long

    UsdRws = Range("C" & Rows.Count).End(xlUp).Row

    For i = UsdRws To 2 Step -1

        pos =instr(1, cells(i, "C").value2, "cat", vbtextcompare)

        If pos > 0 and pos < 5 Then
            Rows(i).Cut Sheets("AWP DEFECTS").Range("A" & rows.Count).End(xlUp).Offset(1)
            Rows(i).Delete
        End If

    Next i

End Sub

Answer 2

Критерий резервного копирования (Скрыть / Удалить)

Чтобы разрешить удаление строк в исходной рабочей таблице, необходимо установить cDEL в True в разделе констант.Настройте другие константы в соответствии с вашими потребностями.

Код

Option Explicit
'Option Compare Text

Sub CATDEFECTS()

    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With
    On Error GoTo ProcedureExit

    ' Source Constants
    Const cSource As Variant = "Sheet1"       ' Worksheet Name/Index
    Const cCol As Variant = "C"               ' Search Column Letter/Number
    Const cFirstR As Long = 2                 ' First Row Number
    Const cChars As Long = 6                  ' Number of Chars
    Const cSearch As String = "CAT"           ' Search String
    ' Target Constants
    Const cTarget As Variant = "AWP DEFECTS"  ' Worksheet Name/Index
    Const cColTgt As Variant = "A"            ' Column Letter/Number
    Const cFirstRTgt As Long = 2              ' First Row Number
    Const cDEL As Boolean = False             ' Enable Delete (True)
    ' Variables
    Dim rngH As Range     ' Help Range
    Dim rngU As Range     ' Union Range
    Dim vntS As Variant   ' Source Array
    Dim i As Long         ' Source Range Row Counter

    ' The Criteria
    ' When the first "cChars" characters do not contain the case-INsensitive
    ' string "cSearch", the criteria is met.

    ' Source Worksheet
    With ThisWorkbook.Worksheets(cSource)
        ' Calculate Last Cell in Search Column using the Find method and
        ' assign it to Help (Cell) Range.
        Set rngH = .Columns(cCol).Find("*", , xlFormulas, _
                xlWhole, xlByColumns, xlPrevious)
        ' Calculate Source Column Range from Help (Cell) Range.
        If Not rngH Is Nothing Then   ' Last Cell was found.
            ' Calculate Source Column Range and assign it to
            ' Help (Column) Range using the Resize method.
            Set rngH = .Cells(cFirstR, cCol).Resize(rngH.Row - cFirstR + 1)
            ' Copy Help (Column) Range into 2D 1-based 1-column Source Array.
            vntS = rngH
            ' Show hidden rows to prevent  the resulting rows (the rows to be
            ' hidden or deleted) to appear hidden in Target Worksheet.
            rngH.EntireRow.Hidden = False
          Else                        ' Last Cell was NOT found (unlikely).
            MsgBox "Empty Column '" & cCol & "'."
            GoTo ProcedureExit
        End If
        ' Loop through rows of Source Array.
        For i = 1 To UBound(vntS)
            ' Check if current Source Array value doesn't meet Criteria.
            If InStr(1, Left(vntS(i, 1), cChars), cSearch, vbTextCompare) = 0 _
                    Then ' "vbUseCompareOption" if "Option Compare Text"

            ' Note: To use the Like operator instead of the InStr function
            ' you have to use (uncomment) "Option Compare Text" at the beginning
            ' of the module for a case-INsensitive search and then outcomment
            ' the previous and uncomment the following line.
'            If Not Left(vntS(i, 1), cChars) Like "*" & cSearch & "*" Then

                Set rngH = .Cells(i + cFirstR - 1, cCol)
                If Not rngU Is Nothing Then
                    ' Union Range contains at least one range.
                    Set rngU = Union(rngU, rngH)
                  Else
                    ' Union Range does NOT contain a range (only first time).
                    Set rngU = rngH
                End If
            End If
        Next
    End With

    ' Target Worksheet
    If Not rngU Is Nothing Then ' Union Range contains at least one range.
        With ThisWorkbook.Worksheets(cTarget)
            ' Calculate Last Cell in Search Column using the Find method and
            ' assign it to Help Range.
            Set rngH = .Columns(cColTgt).Find("*", , xlFormulas, _
                    xlWhole, xlByColumns, xlPrevious)
            ' Calculate Last Cell from Help Range, but in column 1 ("A").
            If Not rngH Is Nothing Then   ' Last Cell was found.
                Set rngH = .Cells(rngH.Row + 1, 1)
              Else                        ' Last Cell was NOT found.
                Set rngH = .Cells(cFirstRTgt - 1, 1)
            End If
            ' Copy the entire Union Range to Target Worksheet starting from
            ' Help Range Row + 1 i.e. the first empty row (in one go).
            ' Note that you cannot Cut/Paste on multiple selections.
            rngU.EntireRow.Copy rngH
        End With
        ' Hide or delete the transferred rows (in one go).
        If cDEL Then  ' Set the constant cDEL to True to enable Delete.
            rngU.EntireRow.Delete
          Else        ' While testing the code it is better to use Hidden.
            rngU.EntireRow.Hidden = True
        End If
    End If

ProcedureExit:

    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With

End Sub

Замечания

• Использование массива значительно не ускорилось.
• Функция InStr была на несколько миллисекунд быстрее, чем оператор Like в моем наборе данных.
• Вычисление реального использованного диапазона и копирование его в массив источников, а затем запись данных, соответствующихкритерии из исходного массива в целевой массив и копирование целевого массива в конечный рабочий лист могут быть быстрее и / но дополнительно копировать данные без формул и форматирования.

Answer 3

Независимо от того, как вы решите реализовать макрос, ваш тест на отсутствие пустых ячеек будет полностью лишним.Вы можете просто проверить, соответствует ли ячейка вашим CAT критериям.Если это так, то оно определенно не пустое, поэтому нет необходимости проверять его.

---

Метод 1

Вы можете просмотреть первые 6 символов с помощью LEFT(Range, 6)

If Left(Range("C" & i), 6) Like "*CAT*" Then

Для работы требуется Option Compare (Спасибо @Comintern)

---

Метод 2

Я бы предпочел этот метод.Он явный и не удаляет и не сдвигает что-либо внутри цикла, поэтому ваши операторы действий значительно минимизируются.

Sub Cat()

Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1") '<--UPDATE
Dim ps As Worksheet: Set ps = ThisWorkbook.Sheets("AWP DEFECTS")

Dim LR As Long, DeleteMe As Range, i As Long
LR = ws.Range("C" & ws.Rows.Count).End(xlUp).Row

For i = 2 To LR
    If InStr(Left(ws.Range("C" & i), 6), "CAT") Then
        If Not DeleteMe Is Nothing Then
            Set DeleteMe = Union(DeleteMe, ws.Range("C" & i))
        Else
            Set DeleteMe = ws.Range("C" & i)
        End If
    End If
Next i

Application.ScreenUpdating = False
    If Not DeleteMe Is Nothing Then
        LR = ps.Range("A" & ps.Rows.Count).End(xlUp).Row
        DeleteMe.EntireRow.Copy ps.Range("A" & LR)
        DeleteMe.EntireRow.Delete
    End If
Application.ScreenUpdating = True

End Sub