Как вытащить н6омера из таблицы?!!!!

[Zazaka]

вот что есть:
"ул.Уральская198 кв.72
89184825212"

"1-ый переулок Онежской23
2369628
89722414395"

г. Краснодар ул. Рождественская-Набережная дом 15 кв. 5



8-918-139-24-85
928-432-35-44
г. Славянск на Кубани ул. Победы 258 тел.89184032619
"ул.Тюляева18 кв.252
891884441112"
8-964-93-51-556

г.Краснодар, ул.1 мая 47/1, дом.2576132, 89604952143
918-140-28-29
"г. Краснодар, ул. Ордженикидзе д. 19, кв. 10
8-918-3315065"
т. 8-909-453-1713
"Ставропольская 230 кв.12
2330797
89189659022"
253-53-64 8928-03-90-691
"г.Краснодар ул.Селезнёва 130кв.41
2342948"
8-918-069-22-19
г. Краснодар, 89184833410
918-387-39-25

918-46-81-282
8-918-441-07-04
"Анапа
пер Сиреневый 24
8-918-4652024"
928-07-00-795
"г. Краснодар, ул. Головатого, д. 302, кв. 62
2536200
2404965"
961-5999-875
8-962-954-36-50
"г. Краснодар ул. Симферопольская д.30 к. 1 кв. 93
тел.: 260-04-99"
2250705 89186927903
8909-97-36
"Краснодар, власова 92,
тел. 88612221629
тел. 9604900587"
"254-14-42
8-918-34-08-520"
"г.Красродар ул.Симферопольская18-110
тел,89182422159"

вот что надо:

918*******
918*******
918*******
918*******
918*******

[nilem]

Можно так попробовать. Запишет номер в ст. В, если он (номер) есть в соответствующей яч. ст. А:

Sub rtyrty()
Dim rng As Range, r As Range
Set rng = Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row)
With CreateObject("VBScript.RegExp")
    .Pattern = "918[0-9- ]+"
    For Each r In rng
        If .Test(r.Text) Then r.Next = Replace(.Execute(r.Text)(0), "-", "")
    Next r
End With
End Sub