макрос выдергивает телефонные номера

[rpolimer]

Фсем привет.
я совсем новеньки в VBA до этого занимался ASM, поэтому начну с глупых вопросов.
пре до мной встала задача написать прогу выдергивающую номера сотиков из документа и записать их в новый документ чтоб каждый номер на новой строчке, а потом привести их к виду +7 ##########

я состряпал вот такой совсем сырой макрос, он ставит курсор в начало документа, ищет номер сотика вырезает его и записыват его в конец списка и нажимает на ентер

Sub Макрос1()
'
' Макрос1 Макрос
'
'
ActiveWindow.ActivePane.VerticalPer centScrolled = 0
Selection.MoveUp Unit:=wdScreen, Count:=1
Selection.HomeKey Unit:=wdLine
Selection.Find.ClearFormatting
With Selection.Find
.Text = "^#^?^#^#^#^#^#^#^#^#^#^#"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
Selection.Cut
ActiveWindow.ActivePane.VerticalPer centScrolled = 86
Selection.MoveDown Unit:=wdScreen, Count:=1
Selection.EndKey Unit:=wdLine
Selection.TypeParagraph
Selection.PasteAndFormat (wdPasteDefault)
ActiveWindow.ActivePane.VerticalPer centScrolled = 0
Selection.MoveUp Unit:=wdScreen, Count:=1

'---------------------тоже самое только теперрь если попалось запись например с двумя пробелами --------------------------------------
ActiveWindow.ActivePane.VerticalPer centScrolled = 0
Selection.MoveUp Unit:=wdScreen, Count:=1
Selection.HomeKey Unit:=wdLine
Selection.Find.ClearFormatting
With Selection.Find
.Text = "^#^?^?^#^#^#^#^#^#^#^#^#^#"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
Selection.Cut
ActiveWindow.ActivePane.VerticalPer centScrolled = 86
Selection.MoveDown Unit:=wdScreen, Count:=1
Selection.EndKey Unit:=wdLine
Selection.TypeParagraph
Selection.PasteAndFormat (wdPasteDefault)
ActiveWindow.ActivePane.VerticalPer centScrolled = 0
Selection.MoveUp Unit:=wdScreen, Count:=1


End Sub


но хочется его зациклить чтобы напрмер дошел до конца документа записал все номера в конце и остановился.

[rpolimer]

если несложно сделайте пожалуйста небольшие коментарии в тексте программы. хочу разоьраться а не просто решить и отложить в сторону!

[Sasha_Smirnov]

Предлагаю шаблон поиска (в окне по Ctrl-F) использовать c подстановочными знаками, как это сделано у viter.alex’а в посте #6 темы Макрос: найти все, копировать.

А чего ж на уже освоенном ассемблере не забацали?

[maykkk]

А я выдергиваю номера телефонов вот этими тремя макросами....

Sub ВырезаемНОМЕРтелефона1()
'извлекает все email из документа и размещает в новом документе столбиком
Dim Source As Document, Target As Document, myRange As Range
Set Source = ActiveDocument
Set Target = Documents.Add
Application.ScreenUpdating = False
Source.Activate
Selection.HomeKey Unit:=wdStory
Selection.Find.ClearFormatting
With Selection.Find
Do While .Execute(findText:="0??-???-??-??", _
MatchWildcards:=True, Wrap:=wdFindStop, Forward:=True) = True
Set myRange = Selection.Range
Target.Range.InsertAfter myRange & vbCr
Loop
End With
Selection.HomeKey Unit:=wdStory
Target.Activate
End Sub


Sub ВырезаемНОМЕРтелефона2()
'извлекает все email из документа и размещает в новом документе столбиком
Dim Source As Document, Target As Document, myRange As Range
Set Source = ActiveDocument
Set Target = Documents.Add
Application.ScreenUpdating = False
Source.Activate
Selection.HomeKey Unit:=wdStory
Selection.Find.ClearFormatting
With Selection.Find
Do While .Execute(findText:=" ???-??-??", _
MatchWildcards:=True, Wrap:=wdFindStop, Forward:=True) = True
Set myRange = Selection.Range
Target.Range.InsertAfter myRange & vbCr
Loop
End With
Selection.HomeKey Unit:=wdStory
Target.Activate
End Sub


Sub ВырезаемНОМЕРтелефона3()
'извлекает все email из документа и размещает в новом документе столбиком
Dim Source As Document, Target As Document, myRange As Range
Set Source = ActiveDocument
Set Target = Documents.Add
Application.ScreenUpdating = False
Source.Activate
Selection.HomeKey Unit:=wdStory
Selection.Find.ClearFormatting
With Selection.Find
Do While .Execute(findText:=" ??-??-??", _
MatchWildcards:=True, Wrap:=wdFindStop, Forward:=True) = True
Set myRange = Selection.Range
Target.Range.InsertAfter myRange & vbCr
Loop
End With
Selection.HomeKey Unit:=wdStory
Target.Activate
End Sub

может это уровень"лопаты"...но работает настолько надежно.Запускаю по очереди...получается три Вордовских док.(вырезает столбиком)..затем переношу в Ексель ...макросом...и тут уже "разбираюсь" с ними....но дальнейшая судбба №телефонов ...это накопление в базе(просто в Ехеле),а что бы "уложить " их туда...надо убрать тире(-).....но вот фокус...макрос кот у меня есть режет не только (-)тире но и "выкашивает"нули(0) в начале номера...что в макросе "подправить "что бы он убирал только тире(-)...,а нули оставлял...вот макрос ...Я уже его ерзал,ерзал по столу...он или не работает или выкашивает все...

Sub Convert_Phone()
Application.ScreenUpdating = False
'
'
'
With Selection.SpecialCells(xlConstants)

.Replace what:="-", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByColumns, MatchCase:=True

End With


'
Application.ScreenUpdating = True
End Sub
..кто,что может сказать на эту тему......

[viter.alex]

Сообщение от maykkk

..кто,что может сказать на эту тему......

Перед удалением тире сделай ячейки текстовыми, тогда незначащие нули удаляться не будут. Или в формате ячейки сделать так, чтобы незначащие нули не обрезались. Если такое возможно

[maykkk]

Проблему просто "обошел" стороной.Вместе с тире полюбому выкашиваетсяи 0 .Поэтому ...Выкашиваю ( -) и (0)....форматированием000-000-00-00....выставляю перед первой цифрой (0)...перегоняю материал в Ворд и тутже возвращаю назад в Ехсель..Получается прилетает СОДЕРЖАНИЕ текст и вставляю в ячейку с форматированием ТЕКСТ(и вставляю его как текст) ...только в таком случае удается ...оставить,зафиксировать (0)ноль первой цифрой числа.