Статьи из блога

Макрос извлечения адресов e-mail и размещение их в новом документе

Максим интересуется:

Имею большое количество документов с адресами e-mail. Их-то мне и нужно собрать воедино, в один столбец, а еще лучше сразу в ексель.

Для решения этой задачи воспользуйтесь следующим макросом. Он извлекает все адреса e-mail из текста оригинала документа и помещает их столбиком в новый документ.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
Sub CopyAddressesToOtherDoc()
'извлекает все 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-9A-z._-]{1;}\@[A-z.]{1;}", _
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

Если вы не знаете, как подключить к документу и применить эти макросы, изучите следующие заметки с сайта:

Создание макроса из готового кода

Автоматическая запись макроса

Рубрика: Вопрос-Ответ, Макросы
Метки:
Просмотров: 34821
Подписаться на комментарии по RSS
Версия для печати

[Ссылки на статью]

twitter.com facebook.com vkontakte.ru odnoklassniki.ru mail.ru ya.ru rutvit.ru myspace.com technorati.com digg.com friendfeed.com pikabu.ru blogger.com liveinternet.ru livejournal.ru memori.ru google.com bobrdobr.ru mister-wong.ru yahoo.com yandex.ru del.icio.us

Еще записи по вопросам использования Microsoft Word:

Комментариев: 31

  1. Эндрю
    19.01.2009 в 22:16 | #1

    Я попробовал в адресе vfjkz@i-systems.ru распознаёт только vfjkz@i. Как исправить?

  2. Александр Витер
    19.01.2009 в 22:31 | #2

    Я попробовал в адресе vfjkz@i-systems.ru распознаёт только vfjkz@i. Как исправить?

    Добавь в эту строку

    1
    Do While .Execute(findText:="[+0-9A-z._-]{1;}\@[A-z.]{1;}", _

    После «[A-z» еще и дефис «-»

  3. Zokir
    25.01.2009 в 13:28 | #3

    У меня есть список адресов, как изменить макрос чтобы выбрать только яндекс или рамблер почту

  4. Александр Витер
    25.01.2009 в 16:04 | #4

    У меня есть список адресов, как изменить макрос чтобы выбрать только яндекс или рамблер почту

    Если быстро, то вот так. Хотя можно оптимизировать

    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    Sub CopyAddressesToOtherDoc()
      'извлекает все 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-9A-z._-]{1;}\@(rambler)[A-z.-]{1;}", _
          MatchWildcards:=True, Wrap:=wdFindStop, Forward:=True) = True
          Set myRange = Selection.Range
          Target.Range.InsertAfter myRange & vbCr
        Loop
      End With
      Source.Activate
      Selection.HomeKey Unit:=wdStory
      Selection.Find.ClearFormatting
      With Selection.Find
        Do While .Execute(findText:="[+0-9A-z._-]{1;}\@(yahoo)[A-z.-]{1;}", _
          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

  5. Александр Витер
    26.01.2009 в 15:55 | #5

    Антон, неужели появилась подсветка кода в комментариях?

    Большое спасибо.

  6. Админ
    26.01.2009 в 20:02 | #6

    Александр, нет, это я отредактировал ваш комментарий, так как он был кракозябрами.

  7. Александр Витер
    26.01.2009 в 20:33 | #7

    Александр, нет, это я отредактировал ваш комментарий, так как он был кракозябрами.

    Жалко:((

  8. МИхаил
    05.08.2009 в 20:00 | #8

    Имею большое колличество документов с адресами e-mail. Их-то мне и нужно собрать воедино, в один столбец, а еще лучше сразу в ексель

    как же сделать привязку к экселю?

  9. Александр Витер
    07.08.2009 в 08:55 | #9

    Привязка к Excel делается очень просто. В редакторе VBA Tools→References подключить библиотеку Microsoft Excel Object Library и можно работать с Excel как обычно: будут доступны все объекты и методы Excel

    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    Sub WorkWithExcel()
      Dim xlApp As Excel.Application 'Переменная для приложения Excel
      Dim xlWb As Excel.Workbook 'Переменная для рабочей книги Excel
       
      Set xlApp = New Excel.Application 'Создаем новый экземпляр приложения
      xlApp.Visible = True 'Делаем приложение видимым
      Set xlWb = xlApp.Workbooks.Add 'Добавляем рабочую книгу
       
      With xlWb
        .Sheets(1).Cells(1, 1) = Documents(1).FullName 'В первую ячейку первого листа записываем полное имя первого документа Word
        .SaveAs Documents(1).Path & "\1.xls" 'Сохраняем рабочую книгу в папку с документом
        .Close 'Закрываем рабочую книгу
      End With
       
      Set xlWb = Nothing 'Удаляем ссылку на рабочую книгу
       
      xlApp.Quit 'Выходим из приложения Excel
      Set xlApp = Nothing 'Удаляем ссылку на приложение
    End Sub

  10. Виктор
    21.08.2009 в 08:09 | #10

    а можно сделать так, что бы макрос извлекакл из документа назваия таблиц с номерами и названиями, формат названия таблицы "Таблица 1.2.3 - Название таблицы"

    названия таблиц разные и имеют разную длину,

  11. Александр Витер
    21.08.2009 в 08:52 | #11

    Можно это сделать.

    Предлагаю два варианта. Первый макрос работает со всеми таблицами в документе. Поскольку название таблицы обычно содержится в абзаце, который стоит непостредственно перед таблицей, то нужно просто скопировать содержимое этого абзаца

    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    Sub ExtractTableCaptions1()
    'Извлечение названий таблиц из документа
    'Для всех таблиц в документе
      Dim oTbl As Table
      Dim oResultDoc As Document 'Документ, в который будем записывать заголовки таблиц
      Dim oSourceDoc As Document: Set oSourceDoc = ActiveDocument 'Исходный документ
      'Добавляем документ
      Set oResultDoc = Documents.Add
      'Перебираем все таблицы в документе
      For Each oTbl In oSourceDoc.Tables
        'В новый документ записываем содержимое абзаца, который предшествует таблице
        oResultDoc.Range.InsertAfter oTbl.Range.Paragraphs(1).Previous.Range.Text
      Next
      'Делаем результирующий документ активным
      oResultDoc.Activate
    End Sub

    Второй макрос работает только с таблицами, которые имеют название. Название для таблиц представляет собой поле SEQ с идентификатором Таблица. Макрос ищет такие поля в документе и копирует содержимое всего абзаца, в котором это поле находится.

    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    Sub ExtractTableCaptions2()
    'Извлечение названий таблиц из документа
    'Только для таблиц, имеющих название
      Dim oFld As Field
      Dim oResultDoc As Document
      Dim oSourceDoc As Document: Set oSourceDoc = ActiveDocument
      Set oResultDoc = Documents.Add
      'Перебираем все поля в документе
      For Each oFld In oSourceDoc.Fields
        'Если поле является полем последовательности и в нем есть идентификатор "Таблица"
        If oFld.Type = wdFieldSequence And CBool(InStr(oFld.Code.Text, "Таблица")) Then
          'Копируем содержимое абзаца, в котором это поле находится
          oResultDoc.Range.InsertAfter oFld.Result.Paragraphs(1).Range.Text
        End If
      Next
      'Делаем результирующий документ активным
      oResultDoc.Activate
    End Sub

  12. Katana78
    14.05.2010 в 12:39 | #12

    А можно отфильтровать все полученные mail, и удалить лишние повторяющиеся.

  13. Денис
    26.05.2010 в 16:31 | #13

    вот к примеру у меня такая надпись:

    http://otvet.mail.ru/question/40769690/#url?to=naumova59@mail.ruhttp://otvet.mail.ru/question/40769690/#url?to=pushkareva-82@mail.ruhttp://otvet.mail.ru/question/40769690/#url?to=svet-lya-4ok@mail.ru

    подскажите код макроса, что бы извлечь все E-mail адреса от знака = и до http:// в новый документ столбиком и в случаи повторения E-mail адрес не вписывались в новый документ

    подскажите пожалуйста.

  14. Александр Витер
    27.05.2010 в 03:28 | #14

    Предложу такой вариант: заменить все гиперссылки на знак абзаца, затем это отсортировать, а уже отсортированные абзацы легко проверить на повторяемость. Могу реализовать всё это за вознаграждение.

  15. Денис
    27.05.2010 в 12:40 | #15

    Спасибо не надо.

    Люди подсказали уже

    кому надо ловите

    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    Sub RemoveHrefs()
      Dim NewDoc As Document
      Dim CurrDoc As Document
      Set CurrDoc = ActiveDocument
      Set NewDoc = Documents.Add
      NewDoc.Range.InsertAfter CurrDoc.Range.Text
      NewDoc.Range.Find.Execute FindText:="http:*=", _
                        MatchWildcards:=True, _
                              ReplaceWith:="^0013", _
                              Replace:=wdReplaceAll
    End Sub

  16. Александр Витер
    27.05.2010 в 13:11 | #16

    Но ведь от повторений это не избавляет. А макрос мой©

  17. Денис
    28.05.2010 в 14:01 | #17

    твой не отрицаю *Александр Витер*

    А как от повторения избавится?)

    И,чтоб в место абзаца ^0013 было с новой строки

  18. Александр Витер
    28.05.2010 в 14:10 | #18

    Я же написал: сортировать, а затем, перебирая абзацы один за другим удалять повторы

    А почему ты считаешь, что абзац и новая строка это разные понятия в данном случае? Строго говоря, разные, но в этом случае — одно и то же

  19. Денис
    29.05.2010 в 17:51 | #19

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

  20. Katana78
    01.06.2010 в 13:43 | #20

    КАК удалить повторяющиеся АДРЕСА?

  21. Админ
    01.06.2010 в 14:24 | #21

    Через "Поиск и замену". На сайте полно заметок и комментариев по этому вопросу.

  22. Евгений
    17.06.2010 в 22:10 | #22

    КАК удалить повторяющиеся АДРЕСА?

    В excell есть такая возможность: Данные-расширеный фильтр (Дополнительно в 2007),выбираем диапазон где нужна фильтрация, ставим флажоки "копировать результат в другое место" и "только уникальные записи" потом выделяем диапазон куда будет скопирован результат

    Удачи!

  23. Сергей
    14.12.2010 в 01:05 | #23

    А можно ли в екселе сделать с помощью макросов так:

    в файле вставлено много картинок, которые которые имеют замещающий текст. Так вот, необходимо, что бы замещающий текст остался виден, а картинки пропала. Подскажите кто знает.

  24. Михаил
    03.07.2011 в 14:25 | #24

    После вот этой строчки

    Set Target = Documents.Add

    создаётся новый документ и прекращается выполнение макроса

    есть какие-то мысли?

  25. Антон
    19.02.2012 в 21:08 | #25

    Здравствуйте!

    Данный макрос почему то не работает в Word 2010

    Он не совместим с данной версией?

    glaza-v-glaza@mail.ru

  26. Александр Витер
    20.02.2012 в 20:10 | #26

    Дело не в версии. Замените в коде [ и ] на [ и ] соответственно и всё заработает.

  27. Аноним
    30.03.2012 в 12:09 | #27

    Дело не в версии. Замените в коде [ и ] на [ и ] соответственно и всё заработает.

    тут нет опечатки? мы заменяем и на и?

  28. smok
    24.06.2012 в 11:05 | #28

    помогите с MS 2010

  29. Комментатор 150
    21.12.2017 в 10:44 | #29

    В word 2016 необходимо в строке задающий поиск заменить ; на ,

    [+0-9A-z._-]{1,}\@[A-z.]{1,}

  30. alex
    29.10.2019 в 20:42 | #30

    СПАСИБО!

  31. Дмитрий
    12.12.2021 в 01:53 | #31

    Спасибо

Оставьте комментарий!

(обязательно)

контакты

 
^ Наверх