Удалить массивы строк, которые не содержат значений в ячейках I1 J1 K1

Question

У меня есть строковые массивы в AC23-AC130 в формате 2,5,8 и 7,8,8.

Я ищу код для установки данных, которые должны быть проверены на I1: K1, если это значение не соответствует 1, все массивы строк, которые не соответствуют I1 J1 K1, должны быть удалены.

Я пробовал код на кнопке, но он не проходит.

поэтому нормальные номера в I1 J1 K1 должны быть проверены на диапазон строк. Например, если I1 J1 K1 равно 8 7 7, то все строки, которые не содержат 8 7 7, должны быть удалены. Пример: 2,4,1 не содержат 8 7 7, поэтому его необходимо удалить. 4,5,8 содержит 8, поэтому его не следует удалять.

Sub Tester() 

Dim sKeep As String, x As Long 
Dim rngSearch As Range, c As Range 

    'J1:K1 has values to keep and checked against arrays Ac23-ac130 
    sKeep = Chr(0) & Join(Application.Transpose(Range("j1:k1").Value), _ 
           Chr(0)) & Chr(0) 

    Set rngSearch = Range("AC23:AC130") 

    For x = rngSearch.Cells.Count To 1 Step -1 
     Set c = rngSearch.Cells(x) 
     If InStr(sKeep, Chr(0) & c.Value & Chr(0)) = 0 Then 
      c.Delete shift:=xlShiftUp 
     End If 
    Next x 

End Sub 

Answer 1

ниже код перебирает все ячейки в колонке AC («AC23: AC130»), и для каждой ячейки это с помощью Split поместить значения в массиве.

После этого он проверяет каждую ячейку диапазона («I1: K1») и использует Application.Match, чтобы узнать, существует ли массив в одной из ячеек. Если это так, то он не удаляет его, если нет совпадения, тогда он удаляет текущую ячейку.

Код

Sub Tester() 

Dim sKeep As String, x As Long 
Dim rngSearch As Range, c As Range 
Dim CelArr As Variant, DelFlag As Boolean 

Set rngSearch = Range("AC23:AC130") 

For x = rngSearch.Rows.Count To 1 Step -1 

    CelArr = Split(rngSearch.Item(x), ",") '<-- convert values in column AC to array 
    DelFlag = True '<-- init delete flag 

    If Len(Join(CelArr)) > 0 Then '<-- check if array (current cell) is empty 
     For Each c In Range("I1:K1").Cells 
      If Not IsError(Application.Match(CStr(c.Value), CelArr, 0)) Then '<-- if there is at least 1 match, don't delete the cell 
       DelFlag = False '<-- don't delete current cell with a match 
       Exit For 
      End If 
     Next c 
    End If 

    If DelFlag Then rngSearch.Item(x).Delete shift:=xlShiftUp 
Next x 

End Sub 

Answer 2

можно использовать AutoFilter() фильтровать клетки, не соответствующие «I1» и «J1» значения, а затем цикл с помощью таких отфильтрованных ячеек и собрать (с Union()) те, которые не соответствуют «К1»)

Sub Tester() 
    Dim delRng As Range, c As Range 

    With Range("AC22:AC130") 
     .AutoFilter Field:=1, Criteria1:="<>*" & Range("I1").Value & "*", Operator:=xlAnd, Criteria2:="<>*" & Range("J1").Value & "*" '<--| filter cells that don't match the first two criteria 
     If Application.WorksheetFunction.Subtotal(103, .Cells) > 1 Then 
      Set delRng = .Offset(, 1).Resize(1, 1) '<--| set 'delRng' to a "dummy" cell not to have to check it against 'Nothing' at every iteration of subsequent loop 
      For Each c In .Resize(.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible).SpecialCells(xlCellTypeConstants) 
       If InStr(c.Value, Range("k1").Value) = 0 Then Set delRng = Union(c, delRng) '<--| add to 'delRng' cells that don't match the "last" criteria neither 
      Next 
      .Parent.AutoFilterMode = False 
      Set delRng = Intersect(delRng, .Cells) '<--| get rid of the "dummy" 'delRng' cell 
      If Not delRng Is Nothing Then delRng.Delete shift:=xlShiftUp '<--| if any cell to be deleted found then delete t hem in one shot 
     End If 
    End With 
End Sub