Кому нужно будет забирайте, правда нужно будет укоротить его.
Кто может помогите оптимизировать....
Sub ОставитьТолько707и747()
Dim ra As Range, delra As Range
Application.ScreenUpdating = False ' отключаем обновление экрана
Range("A1").Select
' ищем и удаляем ячейки, содержащие заданный текст
' (можно указать сколько угодно значений, и использовать подстановочные знаки)
УдалятьЯчейкиСТекстом = Array("?727???????", _
"?700???????", _
"?701???????", _
"?702???????", _
"?703???????", _
"?704???????", _
"?705???????", _
"?706???????", _
"?708???????", _
"?709???????", _
"?750???????", _
"?751???????", _
"?760???????", _
"?761???????", _
"?762???????", _
"?763???????", _
"?764???????", _
"?771???????", _
"?775???????", _
"?776???????", _
"?777???????", _
"777???????", _
"?771???????")
' перебираем все строки в используемом диапазоне листа
For Each ra In ActiveSheet.UsedRange.Cells
' перебираем все фразы в массиве
For Each word In УдалятьЯчейкиСТекстом
' если в очередной ячейке листа найден искомый текст
If Not ra.Find(word, , xlValues, xlPart) Is Nothing Then
' добавляем ячейку в диапазон для удаления
If delra Is Nothing Then Set delra = ra Else Set delra = Union(delra, ra)
End If
Next word
Next
' если подходящие ячейки найдены, то: (удаляем)
If Not delra Is Nothing Then delra.Value = ""
End Sub
