Использование функции InStr для удаления только похожих значений из диапазона

Question

следующий код использует диапазон для удаления строк из листа, мой журнал не нормализуется, поэтому мой вопрос заключается в том, как я могу использовать функцию InStr здесь, чтобы также удалить как значения , т.е. если «Apple Ltd» находится в диапазоне, тогда он удалит строки, содержащие «яблоко» или наоборот ... Возможно ли это?

Обновление: Строка 28: Требуется объект @freeman. Я не мог заставить «Dim Cel as Range» работать, я вставил как здесь, так и в верхнюю часть листа с тем же результатом. Является синтаксисом, как вы написали «Cel»? Оригинал ниже

Sub Loop_Example() 
    Dim ChkRange As Range 
     Dim Firstrow As Long 
     Dim Lastrow As Long 
     Dim Lrow As Long 
     Dim CalcMode As Long 
     Dim ViewMode As Long 
    Set ChkRange = Sheets("Sheet2").Range("A1:A13") 
     With Application 
      CalcMode = .Calculation 
      .Calculation = xlCalculationManual 
      .ScreenUpdating = False 
     End With 
     With Sheet1 
      .Select 
      ViewMode = ActiveWindow.View 
      ActiveWindow.View = xlNormalView 
      .DisplayPageBreaks = False 
      Firstrow = 2 
      Lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row 
      For Lrow = Lastrow To Firstrow Step -1 
       With .Cells(Lrow, "A") 
        If Not IsError(.Value) Then 
    If Not IsError(Application.Match(.Value, ChkRange, 0)) Then 
    .EntireRow.Delete 
    End If 
    For Each Cell In ChkRange 
     If InStr(1, Cell.Value, .Value) > 0 And Cell.Value <> .Value Then 
     'include the 2nd part of the "AND" to ensure you don't delete based 
     'on a COMPLETE match, only on a partial match as noted in the comments 
     Cell.EntireRow.Delete 
    End If 
    Next 
End If 

End With 
    Next Lrow 
     End With 
ActiveWindow.View = ViewMode 
With Application 
      .ScreenUpdating = True 
      .Calculation = CalcMode 
     End With 
    End Sub 

---

Sub Loop_Example() 
     Dim ChkRange As Range 
      Dim Firstrow As Long 
      Dim Lastrow As Long 
      Dim Lrow As Long 
      Dim CalcMode As Long 
      Dim ViewMode As Long 
     Set ChkRange = Sheets("Sheet2").Range("A1:A13") 
      With Application 
       CalcMode = .Calculation 
       .Calculation = xlCalculationManual 
       .ScreenUpdating = False 
      End With 
      With Sheet1 
       .Select 
       ViewMode = ActiveWindow.View 
       ActiveWindow.View = xlNormalView 
       .DisplayPageBreaks = False 
       Firstrow = 2 
       Lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row 
       For Lrow = Lastrow To Firstrow Step -1 
        With .Cells(Lrow, "A") 
         If Not IsError(.Value) Then 
     If Not IsError(Application.Match(.Value, ChkRange, 0)) Then 
     .EntireRow.Delete 
     End If 
     For Each Cell In ChkRange 
     Dim Cel As Range 
      If InStr(1, Cell.Value, .Value) > 0 And Cell.Value <> .Value Then 
      'include the 2nd part of the "AND" to ensure you don't delete based 
      'on a COMPLETE match, only on a partial match as noted in the comments 
      Cell.EntireRow.Delete 
     End If 
     Next 
    End If 

    End With 
     Next Lrow 
      End With 
    ActiveWindow.View = ViewMode 
    With Application 
       .ScreenUpdating = True 
       .Calculation = CalcMode 
      End With 
     End Sub 

Answer 1

Как вы можете использовать InStr() удалить всю строку? Изменить эту часть кода

If Not IsError(.Value) Then 
    If Not IsError(Application.Match(.Value, ChkRange, 0)) Then 
    .EntireRow.Delete 
    End If 
End If 

к чему-то вроде этого:

Dim cel as range 'put this at the top of your code with your other Dim stmts 
If Not IsError(.Value) Then 
    If Not IsError(Application.Match(.Value, ChkRange, 0)) Then 
    .EntireRow.Delete 
    End If 
'note this changed row. Note carefully the SPELLING 
    for each Cel in ChkRange.Cells 
    if Instr(1, Cel.value, .Value) > 0 and ce.lValue <> .Value then 
     'include the 2nd part of the "AND" to ensure you don't delete based 
     'on a COMPLETE match, only on a partial match as noted in the comments 
     cel.EntireRow.Delete 
    end if 
    next 
End If 

Это, вероятно, будет довольно медленно, так как вам придется петлю через каждую ячейку в ChkRange смотрит, чтобы увидеть, если Sheet1.Cells(Lrow,"I").Value является где-то там.

Примечание: это от верхней части головы и тестировался, но должен работать, или по крайней мере заставить вас закрыть