How to write a macro in Excel to copy cells by condition?

Question

Database

There is a customer base in the cities in different Excel files, you need to write a macro script program
that will show the numbers only with the prefix 707 and 747
Name Address City Telephone1 Phone2 Phone3 Company_1
Panfilova 43 Almaty 870700000000 87470000000 8707000000 87470000000
87272000000 8707000000
87272000000 87272000000 874700000000 Company_4
Panfilova 43 Almaty 87710000000 87272000000 874700000000
I wrote a script to delete lines that do not contain 707 and 747, but I can’t apply it to cells, what should I change in it?
I see the solution to the problem as such: first find all the cells that do not contain 707 and 747 and simply replace them with empty ones, and then combine Cells: Phone1, Phone2, Phone3.
Here's an old macro:
Sub DeletingLinesNotContainingSpecifiedText()
Dim ra As Range, delra As Range, RowContainsWord As Boolean
' find and delete lines NOT containing the given text
' (you can specify as many values ​​as you like, and use wildcards)
Application.ScreenUpdating = False ' disable refresh screen while rows
are deleted DeleteRowsText = Array("?707???????", "?747???????")
' iterate over all rows in the used sheet range
For Each ra In ActiveSheet.UsedRange. Rows
RowContainsWord = False
' loop through all the phrases in the array
For Each word In Delete RowsWithText
' if the desired text is found in the next row of the sheet
If Not ra.Find(word, , xlValues, xlPart) Is Nothing Then RowContainsWord = True
Next word
If RowContainsWord = False Then ' string does not contain any given word
' add string to range to delete
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 ' delete them
end sub

Answer 1

Whoever needs to take it, though it will need to be shortened.
Who can help optimize ....
Sub LeaveOnly 707 and 747()
Dim ra As Range, delra As Range
Application.ScreenUpdating = False ' disable screen updating
Range("A1").Select
' search and delete cells containing the specified text
' (you can specify as many values ​​as you want, and use wildcards)
DeleteCellsText = Array("?727???????", _
"?700???????", _
"?701???????" , _
"?702???????", _
"?703???????", _
"?704???????", _
"?705?????? ?", _
"?706?????",
"?750???????", _
"?751???????", _
"?760???????", _
"?761???????" , _
"?762???????", _
"?763???????", _
"?764???????", _
"?771?????? ?", _
"?775???????", _
"?776???????", _
"?777???????", _
"777????? ??", _
"?771???????")
' loop through all the rows in the used sheet range
For Each ra In ActiveSheet.UsedRange.Cells
' loop through all the phrases in the array
For Each word In DeleteCellsWithText
' if in the next cell sheet found the search text
If Not ra.Find(word, , xlValues, xlPart) Is Nothing Then
' add a cell to the range to delete
If delra Is Nothing Then Set delra = ra Else Set delra = Union(delra, ra)
End If
Next word
Next
' if matching cells are found, then: (delete)
If Not delra Is Nothing Then delra. Value = ""
End Sub