Как написать в Excel макрос копирование ячеек по условию?

Question

[Антон Ахмедалиев]

Имеется база клиентов по городам в разных excel файлах, нужно написать макрос скрипт программу
Которая покажет номера только c префиксом 707 и 747

Наименование Адрес Город Телефон1 Телефон2 Телефон3
Компания_1 Панфилова 43 Алматы 87272000000 87470000000 870700000000
Компания_2 Панфилова 43 Алматы 87470000000 87272000000 870700000000
Компания_3 Панфилова 43 Алматы 87050000000 87272000000 874700000000
Компания_4 Панфилова 43 Алматы 87710000000 87272000000 874700000000

Писал скрипт по удалению строк не содержащих 707 и 747, но вот к ячейкам его применить не могу, что нужно в нем поменять?
Решение задачи вижу таковым сначало найти все ячейки не содержащих 707 и 747 и просто заменить на пустые, а потом объединить Ячейки: Телефон1, Телефон2, Телефон3.

Вот старый макрос:
Sub УдалениеСтрокНеСодержащихЗаданныйТекст()
Dim ra As Range, delra As Range, RowContainsWord As Boolean
' ищем и удаляем строки, НЕ содержащие заданный текст
' (можно указать сколько угодно значений, и использовать подстановочные знаки)

Application.ScreenUpdating = False ' отключаем обновление экрана на время удаления строк
УдалятьСтрокиСТекстом = Array("?707???????", "?747???????")

' перебираем все строки в используемом диапазоне листа
For Each ra In ActiveSheet.UsedRange.Rows
RowContainsWord = False

' перебираем все фразы в массиве
For Each word In УдалятьСтрокиСТекстом
' если в очередной строке листа найден искомый текст
If Not ra.Find(word, , xlValues, xlPart) Is Nothing Then RowContainsWord = True
Next word

If RowContainsWord = False Then ' строка не содержит ни одного заданного слова
' добавляем строку в диапазон для удаления
If delra Is Nothing Then Set delra = ra Else Set delra = Union(delra, ra)
End If
Next

If Not delra Is Nothing Then delra.EntireRow.Delete ' удаляем их
End Sub

Answer 1

[Антон Ахмедалиев]

Кому нужно будет забирайте, правда нужно будет укоротить его.
Кто может помогите оптимизировать....

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