Статьи из блога
Макрос извлечения адресов e-mail и размещение их в новом документе
Максим интересуется:
Имею большое количество документов с адресами e-mail. Их-то мне и нужно собрать воедино, в один столбец, а еще лучше сразу в ексель.
Для решения этой задачи воспользуйтесь следующим макросом. Он извлекает все адреса e-mail из текста оригинала документа и помещает их столбиком в новый документ.
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
Если вы не знаете, как подключить к документу и применить эти макросы, изучите следующие заметки с сайта:
Создание макроса из готового кода
Рубрика: Вопрос-Ответ, Макросы
Метки: макросы
Просмотров: 35168
Подписаться на комментарии по RSS
Версия для печати
Метки: макросы
Просмотров: 35168
Подписаться на комментарии по RSS
Версия для печати
Еще записи по вопросам использования Microsoft Word:
- 10 вопросов и ответов по редактору Word (1 часть)
- 3 способа очистки списка недавно открытых документов
- Word 2007: добавляем свою вкладку и свои команды
- Word 2007: полотно, рисунки, линии
- Word 2007: смена формата сохранения файла
- Word 97 - решение проблемы с отображением символов на линейке
- Абзац с цветным фоном
- Автоматизация текстового набора в Word
- Автоматическая запись макроса
- Автоматическая нумерация билетов
- Автоматическая расстановка переносов
- Автоматическое обновление полей при открытии документа
- Автоматическое сохранение документа при его закрытии
- Автотекст с последовательной нумерацией
- Белый текст на синем фоне в Word 2007
- Быстрая смена ориентации страниц документа
- Быстрое перемещение между открытыми документами Word
- Быстрое создание нового документа на основе шаблона
- Быстрый ввод текста с помощью команды =rand()
- Ввод повторяющихся фрагментов текста в Word 2007
- Ввод часто повторяющихся фрагментов текста
- Вертикальное выравнивание текста
- Возможно ли запретить копирование текста из документа Word?
- Вопрос о работе с графиками (диаграммами) в Word
- Вопросы и ответы о гиперссылках в редакторе Word
Форум
Читают
Обсуждают
страницы
сайты
статистика
Комментариев: 31
Я попробовал в адресе vfjkz@i-systems.ru распознаёт только vfjkz@i. Как исправить?
Добавь в эту строку
Do While .Execute(findText:="[+0-9A-z._-]{1;}\@[A-z.]{1;}", _После «[A-z» еще и дефис «-»
У меня есть список адресов, как изменить макрос чтобы выбрать только яндекс или рамблер почту
Если быстро, то вот так. Хотя можно оптимизировать
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Антон, неужели появилась подсветка кода в комментариях?
Большое спасибо.
Александр, нет, это я отредактировал ваш комментарий, так как он был кракозябрами.
Жалко:((
Имею большое колличество документов с адресами e-mail. Их-то мне и нужно собрать воедино, в один столбец, а еще лучше сразу в ексель
как же сделать привязку к экселю?
Привязка к Excel делается очень просто. В редакторе VBA Tools→References подключить библиотеку Microsoft Excel Object Library и можно работать с Excel как обычно: будут доступны все объекты и методы Excel
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а можно сделать так, что бы макрос извлекакл из документа назваия таблиц с номерами и названиями, формат названия таблицы "Таблица 1.2.3 - Название таблицы"
названия таблиц разные и имеют разную длину,
Можно это сделать.
Предлагаю два варианта. Первый макрос работает со всеми таблицами в документе. Поскольку название таблицы обычно содержится в абзаце, который стоит непостредственно перед таблицей, то нужно просто скопировать содержимое этого абзаца
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 с идентификатором Таблица. Макрос ищет такие поля в документе и копирует содержимое всего абзаца, в котором это поле находится.
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А можно отфильтровать все полученные mail, и удалить лишние повторяющиеся.
вот к примеру у меня такая надпись:
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 адрес не вписывались в новый документ
подскажите пожалуйста.
Предложу такой вариант: заменить все гиперссылки на знак абзаца, затем это отсортировать, а уже отсортированные абзацы легко проверить на повторяемость. Могу реализовать всё это за вознаграждение.
Спасибо не надо.
Люди подсказали уже
кому надо ловите
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Но ведь от повторений это не избавляет. А макрос мой©
твой не отрицаю *Александр Витер*
А как от повторения избавится?)
И,чтоб в место абзаца ^0013 было с новой строки
Я же написал: сортировать, а затем, перебирая абзацы один за другим удалять повторы
А почему ты считаешь, что абзац и новая строка это разные понятия в данном случае? Строго говоря, разные, но в этом случае — одно и то же
когда копируешь результаты в блокнот, отображается все в сроку, а не столбиком почему-то.
КАК удалить повторяющиеся АДРЕСА?
Через "Поиск и замену". На сайте полно заметок и комментариев по этому вопросу.
В excell есть такая возможность: Данные-расширеный фильтр (Дополнительно в 2007),выбираем диапазон где нужна фильтрация, ставим флажоки "копировать результат в другое место" и "только уникальные записи" потом выделяем диапазон куда будет скопирован результат
Удачи!
А можно ли в екселе сделать с помощью макросов так:
в файле вставлено много картинок, которые которые имеют замещающий текст. Так вот, необходимо, что бы замещающий текст остался виден, а картинки пропала. Подскажите кто знает.
После вот этой строчки
Set Target = Documents.Add
создаётся новый документ и прекращается выполнение макроса
есть какие-то мысли?
Здравствуйте!
Данный макрос почему то не работает в Word 2010
Он не совместим с данной версией?
glaza-v-glaza@mail.ru
Дело не в версии. Замените в коде [ и ] на [ и ] соответственно и всё заработает.
тут нет опечатки? мы заменяем и на и?
помогите с MS 2010
В word 2016 необходимо в строке задающий поиск заменить ; на ,
[+0-9A-z._-]{1,}\@[A-z.]{1,}
СПАСИБО!
Спасибо