Статьи из блога
Макрос пакетной замены от Александра Витера
По просьбам читателей сайта разработал свой вариант макроса пакетной замены фрагментов текста в документах Word. Об этом его просили в комментариях к заметке .
Александр предлагает скачать (ниже) бета-версию его разработки кто заинтересован в подобном решении. Вот, что он предлагает.
Это третья бета-версия макроса пакетной замены. Теперь ее нужно тестировать.
Что уже сделано:
1. Доработан механизм поиска в документе. Текст можно заменять как в основном тексте, так и в надписях, в гиперссылках и объектах WordArt.
2. Добавлены опции «Учитывать регистр» и «Слово целиком».
3. Если файл доступен только для чтения, то он просто пропускается. Запись об этом делается в лог-файл. Таким образом, можно работать и с документами в локальной сети.
4. Глубина вложенности каталогов, в которых можно искать файлы, удовлетворяющие шаблону, не ограничена.
5. Каждый сеанс поиска\замены записывается в подробный лог-файл с указанием документа, проведенных в нем замен, затраченного времени и настроек замены.
6. В процессе поиска\замены отображается прогресс-бар.
Я со своей стороны провел тесты, у меня ошибок не возникает. Возможные ошибки я постарался предусмотреть, но над этим еще нужно будет работать.
Итак, пожалуйста скачивайте макрос и пробуйте его в деле. Все замечания по макросу (ошибки, предложения) пишите в комментариях к этой заметке.
Метки: макросы | поиск и замена | полезности
Просмотров: 68912
Подписаться на комментарии по RSS
Версия для печати
Еще записи по вопросам использования Microsoft Word:
- 25 + лучших бесплатных программ для создания слайд-шоу в 2022 году
- 3 способа очистки списка недавно открытых документов
- 45 лучших бесплатных программных инструментов для редактирования видео в 2022 году
- Microsoft Office 2019 - особенности, где скачать
- Microsoft Office 2019 Professional Plus для Windows и Mac OS
- Office 2007 и бесплатный переход на Office 2010
- Ribbon XML Editor — программа редактирования интерфейса Word 2007, 2010
- RuStore: откройте двери в мир российских мобильных приложений
- Абзац с цветным фоном
- Автоматическая запись макроса
- Автоматическая расстановка переносов
- Автоматическое обновление полей при открытии документа
- Автоматическое сохранение документа при его закрытии
- Автотекст и Word 2007
- Азбука MS Office 2007
- Будущее в проектировании и автоматизация разработки проектов - Онлайн конструктор строительной документации
- Бухгалтер и счетовод: в чем разница?
- Быстрая смена ориентации страниц документа
- Быстрое перемещение между открытыми документами Word
- Быстрое создание нового документа на основе шаблона
- Быстрый ввод текста с помощью команды =rand()
- Ввод часто повторяющихся фрагментов текста
- Виртуальный номер SMS – как это работает?
- Виртуальный номер телефона и его преимущества
- Вот как можно незаметно посмотреть чью-то историю в Instagram (обновление 2022 г.)
Форум
Читают
Обсуждают
страницы
сайты
статистика
Комментариев: 85
Добрый день!
С интересом читаю ваш проект. Спасибо за полезный труд!
У меня есть пара вопросов по Word. Думаю, многим будут они интересны. К сожалению, не разобрался, как можно опубликовать эти вопросы на сайте? Если не затруднит, подскажите, пожалуйста.
Заранее благодарю.
С уважением, Николай
Николай, вопросы (и ответы) публикую на сайте я сам. А задать их вы можете через наш Форум.
а) Не хватает подробной информации в логе: сколько замен сделано, сколько и каких строк найдено.
б) Нужен то ли запрос нf запись итогового файла, то ли предусмотреть бэкап.
в) Хотелось бы поиска/замены с использованием регулярных выражений: например, мне надо не просто найти строки, а убить их, не оставляя пустых абзацев. Найти строки и заменить на них же, но с добавлением своей строки. Найти и заменить формат. Ну и всё остальное, что может показаться "бешенством с жиру".
А в предложенном варианте работает как зверь. Автору респект!
Спасибо за макрос, работает хорошо.
Присоединяюсь к пожеланиям Игоря (см.выше).
Ещё раз спасибо.
Игорь и Ольга!
Я думал с самого начала о возможности записи в лог-файл количества замен. Но это очень сильно затормозит работу макроса (приблизительно на 40%), потому что встроенного механизма, чтобы получить это число, у Word'а нет;
Перезапись исходного файла я сделаю в виде опции в диалоговом окне;
Регулярные выражения стоят у меня в TODOlist, но не доходят руки
Огромный респект Автору.
Программка супер - то, что доктор прописал.
Поработав немного понял, что мне катастрофически не хватает подробной информации в логе: сколько замен сделано и каких строк найдено.
В моем случае можно пожертвовать временем но инфу о количестве замен нужно знать.
Немного доработал программку:
1) Возможность выбора замены только в основном тексте (мне лично пригодилось);
2)Добавляет запись в лог о количестве сделанных замен или отсутствии таковых;
Провел испытания на затрачиваемое время, использовал 10 документов в каждом 10 000 изменений.
1)Исходная программа
Обработано 10 документов
Затрачено 413,047 сек.
2)Доработанная
Обработано 10 документов
Затрачено 537,281 сек.
Разница 120 сек - для такого огромного объема в моем случае приемлемо.
Кому интересна версия с указанными доработками вот ссылка .
Автору еще раз ОГРОМНОЕ спасибо.
Обилие комментариев в исходном коде - очень помогло.
Может я не совсем по теме, но подскажите можно ли написать такой макрос, который находит фрагмент текста и копирует его в новый файл, и в месте с фрагментом копирует символов 50 вверх и вниз от фрагмента. Это возможно?
Посмотрите как пример.
Можно, например таким макросом
Sub CopyText() Dim oDoc As Document 'Исходный документ Dim oNewDoc As Document 'Новый документ Dim sSearchString As String 'Строка поиска Dim nStart As Long, nEnd As Long 'Начало и конец текста, который нужно скопировать Set oDoc = ActiveDocument sSearchString = Selection.Text With oDoc.Range.Find .Text = sSearchString .Execute If .Found Then 'Если начало найденного фрагмента отстоит от начала документа менее, чем на 50 символов nStart = IIf(.Parent.Start < 50, 0, .Parent.Start - 50) 'Если конец найденного фрагмента отстоит от конца документа менее, чем на 50 символов nEnd = IIf(oDoc.Range.End - .Parent.End < 50, oDoc.Range.End, .Parent.End + 50) Set oNewDoc = Documents.Add oNewDoc.Range.InsertAfter oDoc.Range(nStart, nEnd).Text End If End With Set oDoc = Nothing Set oNewDoc = Nothing End SubПопробовал собрать из двух макросов один чтобы можно вводить данные, искать их и записывать в другой файл в диапазоне 100 символов от введеного слова, но без результатно. Помогите пожалуйста.
Sub Макрос1() Dim oDoc As Document 'Исходный документ Dim oNewDoc As Document 'Новый документ Dim sSearchString As String 'Строка поиска Dim nStart As Long, nEnd As Long 'Начало и конец текста, который нужно скопировать Do sSearchString = InputBox("Введите слово в поле:", "Поиск слов") If sSearchString = 0 Then Exit Sub ElseIf Len(sSearchString) = 0 Then MsgBox "Введите пожалуйста слово" & vbCr & "или нажмите кнопку 'Cancel" End If Loop Until Len(sSearchString) 0 Application.ScreenUpdating = False Set newDoc = Documents.Add Set oDoc = ActiveDocument With oDoc.Range.Find .Text = sSearchString .Execute 'Ищем слово в любом регистре With actDoc.Range.Find .Text = "" .MatchWildcards = True While .Execute Application.StatusBar = "Добавляем " & sSearchString Wend End With If .Found Then 'Если начало найденного фрагмента отстоит от начала документа менее, чем на 50 символов nStart = IIf(.Parent.Start < 50, 0, .Parent.Start - 50) 'Если конец найденного фрагмента отстоит от конца документа менее, чем на 50 символов nEnd = IIf(oDoc.Range.End - .Parent.End < 50, oDoc.Range.End, .Parent.End + 50) Set oNewDoc = Documents.Add oNewDoc.Range.InsertAfter oDoc.Range(nStart, nEnd).Text End If End With Set oDoc = Nothing Set oNewDoc = Nothing CommandBars("Stop Recording").Visible = False End SubПоясните подробнее, что нужно сделать.
Александр, здравствуйте. Нужно чтобы при загрузки макроса появлялось окно InputBox для ввода данных(слово или число) которые нужно найти, затем шел поиск этого слова или числа, а затем скопировать найденные данные в новый документ с диапазоном в 100 символов от указанного слова или числа, то есть 50 символов до и 50 после.
Ваш макрос работает отлично, но нужно чтобы данные не выделялись вручную , а вводились и искались автоматически, с копированием в новый документ.
Нужно просто изменить способ задания строки. В моём макросе строку
нужно заменить на такую:
'Приглашение на ввод строки sSearchString = InputBox("Введите слово в поле:", "Поиск слов") 'Если ничего не ввели или нажали «Отмена», то выходим из процедуры. If Len(sSearchString) = 0 Then Exit SubЕсли же нужно, чтобы все результаты поиска записывались в один и тот же документ, тогда строку
нужно поставить перед блоком
Александр, здравствуйте. Не происходит поиска по всему документу все рекомендации выполнил. Ввожу слово,создается документ, в нем диапазон в 100 символов и все дальше искать не хочет.
Sub CopyText() Dim oDoc As Document 'Исходный документ Dim oNewDoc As Document 'Новый документ Dim sSearchString As String 'Строка поиска Dim nStart As Long, nEnd As Long 'Начало и конец текста, который нужно скопировать Set oDoc = ActiveDocument 'Приглашение на ввод строки sSearchString = InputBox("Введите слово в поле:", "Поиск слов") 'Если ничего не ввели или нажали «Отмена», то выходим из процедуры. If Len(sSearchString) = 0 Then Exit Sub Set oNewDoc = Documents.Add With oDoc.Range.Find .Text = sSearchString .Execute If .Found Then 'Если начало найденного фрагмента отстоит от начала документа менее, чем на 50 символов nStart = IIf(.Parent.Start < 50, 0, .Parent.Start - 50) 'Если конец найденного фрагмента отстоит от конца документа менее, чем на 50 символов nEnd = IIf(oDoc.Range.End - .Parent.End < 50, oDoc.Range.End, .Parent.End + 50) oNewDoc.Range.InsertAfter oDoc.Range(nStart, nEnd).Text End If End With Set oDoc = Nothing Set oNewDoc = Nothing End SubЗамените этот блок
На такой:
With oDoc.Range.Find .Text = sSearchString While .Execute 'Если начало найденного фрагмента отстоит от начала документа менее, чем на 50 символов nStart = IIf(.Parent.Start < 50, 0, .Parent.Start - 50) 'Если конец найденного фрагмента отстоит от конца документа менее, чем на 50 символов nEnd = IIf(oDoc.Range.End - .Parent.End < 50, oDoc.Range.End, .Parent.End + 50) oNewDoc.Range.InsertAfter oDoc.Range(nStart, nEnd).Text Wend End WithИзвините, что может не по теме =(
У меня проблема следующего характера, есть к примеру таблица с данными (номер договора(акта), Ф.И.О и тд), а также эти договора в .doc формате (к примеру 100 шт.), существуют ли такие флаги(якоря), которые можно расставлять по тексту(договора,акта) в соответствии с данными в таблице. Т.е. если я изменяю данные в таблице например ФИО, то эти данные меняються и в тех документах и местах в документах, где стоят эти так называемые флаги(якоря).
Жду ответа!!!!
Ответьте если сможете!!!
Спасибо.
Андрей, специально для Вас сделано «Слияние»
В каком Word'е вы работаете
Спасибо огромное, за вашу отзывчивость и профессионализм, выручили так выручили. Еще раз спасибо.
Предыдущий макрос был с ошибкой, это рабочий, но ищет не по всему документу. Что нужно сделать? Подскажите пожалуйста.
Sub CopyText() Dim oDoc As Document 'Исходный документ Dim oNewDoc As Document 'Новый документ Dim sSearchString As String 'Строка поиска Dim nStart As Long, nEnd As Long 'Начало и конец текста, который нужно скопировать Set oDoc = ActiveDocument 'Приглашение на ввод строки sSearchString = InputBox("Введите слово в поле:", "Поиск слов") 'Если ничего не ввели или нажали «Отмена», то выходим из процедуры. If Len(sSearchString) = 0 Then Exit Sub Set oNewDoc = Documents.Add With oDoc.Range.Find .Text = sSearchString .Execute If .Found Then 'Если начало найденного фрагмента отстоит от начала документа менее, чем на 50 символов nStart = IIf(.Parent.Start < 50, 0, .Parent.Start - 50) 'Если конец найденного фрагмента отстоит от конца документа менее, чем на 50 символов nEnd = IIf(oDoc.Range.End - .Parent.End < 50, oDoc.Range.End, .Parent.End + 50) oNewDoc.Range.InsertAfter oDoc.Range(nStart, nEnd).Text End If End With Set oDoc = Nothing Set oNewDoc = Nothing End Subстас, я же уже сказал, что нужно изменить в предыдущем ответе на Ваш вопрос
Александр спасибо за понимание, нашел свою ошибку, сейчас все работает как надо. Макрос написанный вами можно использовать телекоммуникации для отсева данных в трейсе. Еще раз СПАСИБО.
Я написал макрос пакетной замены который использует стандартный диалог Word "Найти и заменить" и все его возможности. Ни в одном из предложенных макросов я такого не видел. См. http://alex-mail.at.tut.by
Инженер-программист RAA, один из пользователей моего шаблона VolRepl Beta (http://volrepl.markros.ru), спросил меня, можно ли провести замену текста, находящегося в надписи, сгруппированной с др. объектами (линии, фигуры). А группа в свою очередь размещена в колонтитуле.
В текущей версии шаблона VolRepl Beta такая возможность не предусмотрена, но в ходе переписки с RAA выяснилось, что для стоящей перед ним задачи интерактивная замена не нужна, достаточно выполнять замену в автоматическом режиме. Поэтому я решил порекомендовать ему макрос пакетной замены от Александра Витера. Однако выяснилось, что механизм навигации, использованный в этом макросе, не позволяет выполнять замену текста в расположенных в колонтитулах надписях, содержащихся в группе. Я внес в него необходимые исправления, и исправленный вариант предлагаю вашему вниманию. В этом варианте возможна автоматическая замена текста в надписях, фигурах и объектах WordArt, расположенных колонтитулах, даже если они находятся в группах и/или на полотне. В доступном для загрузке файле SrcAndRpl_Beta3_m1.rar (http://volrepl.markros.ru/SrcAndRpl_Beta3_m1.rar) (57 767 байт) сжат файл SrcAndRpl_Beta3_m1.doc (169 472 байта). Используйте на свой страх и риск.
Мне макрос очень понравился, спасибо автору.
На подходе следующая версия этого макроса с учётом замечаний Марка Розенберга. Будут представлены две версии: для Word 2003 и ниже и для Word 2007 и выше.
Посмотрел макрос SrcAndRpl_Beta3_m1.rar.
Для перебора всех частей документа (в т.ч. все надписи в группах и на полотне), могу посоветовать конструкцию попроще:
Dim R As Word.Range ' части документа For Each R In srDoc.StoryRanges Do ' ...обработка области R... ' вложенные/следующие части Set R = R.NextStoryRange Loop While Not (R Is Nothing) Next RВ колонтитулах надписи не обрабатываются, придется извращаться.
Например, так:
Public Function Macro_TextFrameRun( _ Optional ByRef tfRange As Word.Range = Nothing, _ Optional ByRef tfMacro$ = "", _ Optional ByRef orV2 As Variant, _ Optional ByRef orV3 As Variant, _ Optional ByRef orV4 As Variant, _ Optional ByRef orV5 As Variant) As Long ' запустить макрос для надписей области ' tfRange - область с надписями (Nothing - главная часть) ' tfMacro - имя запускаемого макроса ' orV2-orV5 - параметры передаваемые макросу tfMacro ' возвращает количество успешных запусков макроса tfMacro ' !!! макрос tfMacro запускается командой: ' tfMacro(область текста надписи, orV2, orV3, orV4, orV5) Macro_TextFrameRun = 0 'On Error Resume Next ' тест If Not Range_StoryIfEmpty(tfRange) Then Exit Function Dim S As Word.Shape, O As Word.Shape ' объекты области For Each S In tfRange.ShapeRange Select Case S.Type ' полотно Case msoCanvas: GoSub sub_Canvas ' группа Case msoGroup: GoSub sub_Group ' другие Case Else Set O = S GoSub sub_Run End Select Next S Exit Function sub_Canvas: ' объекты полотна S Dim CI As Word.Shape For Each CI In S.GroupItems If S.Type = msoGroup Then GoSub sub_Group Else Set O = CI GoSub sub_Run End If Next CI Return sub_Group: ' объекты группы S Dim GI As Word.Shape For Each GI In S.GroupItems Set O = GI GoSub sub_Run Next GI Return sub_Run: ' проверка и обработка объекта O ' наличие контейнера If O.TextFrame.HasText True Then Return 'On Error Resume Next ' тест Application.Run _ MacroName:=tfMacro, _ varg1:=O.TextFrame.TextRange, _ varg2:=orV2, _ varg3:=orV3, _ varg4:=orV4, _ varg5:=orV5 If Err.Number = 0 Then _ Macro_TextFrameRun = Macro_TextFrameRun + 1 Return End FunctionСпасибо за внимание к моей работе. В новой версии, которую я пообещал от имени Комментатор 5, надписи в колонтитулах обрабатываются
Александр, спасибо за макрос он очень облегчает людям работу!
у меня вопрос: хочу заменить ФОРМАТЫ, а не текст. такое возможно?
допустим у меня во всех файлах заголовки начинаются вот в таком формате
"обычный, шрифт 15 или 17, синий"
а я хочу менять это все только на формат "заголовок 2"
1. у меня все заголовки синего цвета. можно брать по цвету
2. либо только первую строку во всех текстах поменять на заголовок 2, думаю это уже отдельная работа.
6116402@gmail.com мой адрес. спасибо еще разок
Курману. Посмотрите, может быть, вам подойдет мой шаблон VolRepl Beta (http://volrepl.markros.ru). Только в нем не предусмотрен для поиска размер шрифта (это не принципиальное ограничение, можно доработать, если очень нужно).
Приходится работать с массой документов. Для окочательного однообразия оформление должно быть таким:
Весь текст шрифтом TimesNew Roman
Одинарный интервал
Абзац 6 рт до и после ко всему документу, за исключением таблиц.
Первая строка: 12 рт до, 3 рт - после, жирн;
Вторая строка: 0;0, курсив.
Третья строка:
все ПРОПИСНЫЕ, жирн;
12 pt - до, 12 pt - после
и,
это все для директории, в которой 250-300 файлов.
Может кто подскажет прямой макрос. Заранне спасибо.
Ответ на: ми-007"ьфшдюкг
Здравствуйте. Все здорово все нравится..., но у меня возникает ошибка при поиске и замене строки длиной более 255 символов...
ругается Run-time error 5854, слишком длинный строковый параметр. Можно решить этот вопрос каким-нибудь способом?
Ограничение в 255 символов заложено в диалоге Найти и заменить и в соответствующем методе VBA. В шаблоне VolRepl Beta для замены можно использовать любой фрагмент документа, но длина строки поиска ограничена.
Можно написать макрос, который будет искать первые 255 символов искомого текта и сравнивать следующие символы с искомыми, пока не будет совпадения.
Я не стал этим заниматься, поскольку такая задача встречается редко.
Здравствуйте, Марк! Все просто супер - экономите мне кучу времени на правке документов...
Маленькое пожелание - можно в выводимом отчете указывать количество замен в каждом документе?
Спасибо.
Добрый день! Не могли бы вы подсказать по следующей ситуации? Есть документ, который имеет вид:
====================
фрагмент 1
разнообразного
текста
====================
фрагмент 2
разнообразного
текста
====================
и так далее
необходимо в нем найти слово (или сочетание символов), затем удалить строку содержащую это слово, а также все строки выше и ниже в этом фрагменте, чтобы осталось только это:
====================
====================
Заранее благодарю!!!
И так если надо заменить последовательность символов которая меньше 255 символов, на последовательность более 255 символов сделал такой макрос, может кому и пригодится.
Sub ReplaceInRange(rRange, sFind, sReplace) CopyLen = 255 - Len(sFind) tmp = sReplace If Len(tmp) > CopyLen Then While Len(tmp) 0 tmpReplace = Mid(tmp, 1, CopyLen) tmp = Replace(tmp, tmpReplace, "") rRange.Find.Execute FindText:=sFind, _ ReplaceWith:=tmpReplace + sFind, Replace:=wdReplaceAll Wend End If rRange.Find.Execute FindText:=sFind, _ ReplaceWith:=tmp, Replace:=wdReplaceAll End SubМарк и Александр, огромное спасибо! Ваши макросы, в особенности VolRepl Beta (http://volrepl.markros.ru) - экономят массу времени...
Правда, одну проблему я так и не поборол пока. Можно спросить?
Есть .DOC-файл, в котором около тысячи картинок, вставленных в него через "Вставить -> Рисунок -> Из файла -> Связать с файлом". То есть картинки в DOC-файле не хранятся, а находятся в отдельной папке \Images, и все подключены через "Правка\Связи...". Можно ли осуществить поиск этих всех картинок в тексте и замену каждой картинки на текстовую строку вида
{bmc Images/image_01_name.bmp}, {bmc Images/image_02_name.bmp} и т.д. ?
Да, забыл сказать. Word2003. Rартинки - все BMP и PNG, но будут впоследствии преобразованы только в BMP. Впоследствии, Adobe Robohelp (8.0) for Word на основании имеющегося в моём DOC-файле текста и записей вида {bmc Images/реальное_имя картинки_в_папке.bmp} создаёт HTML help (связанный набор HTML файлов) по заданному мной шаблону. Алгоритм поиска картинок и их замены на {bmc Images/Images/реальное_имя картинки_в_папке.bmp} в Robohelp присутствует. В виде макроса под названием ConvertDocument. Но доступ к этому макросу для пользователей Robohelp запрещён, а набор его возможностей крайне ограничен... В частности, именно этот нехороший макрос ВСЕ повторяющиеся картинки из папки, связанные с DOC-файлом, заменяет сперва на {bmc Images/реальное_имя картинки_в_папке.bmp} (первое вхождение), а затем (если в DOC-файле картинка привязана второй, третий, N-ный раз) - присваивает им имена своим автонумератором - {bmc IMG00001.bmp}, {bmc IMG00002.bmp}, {bmc IMG00003.bmp} и т.д., в порядке следования картинки в тексте... После этого, понять какая картинка была откуда, крайне сложно... Надо сказать, что макрос ConvertDocument в Robohelp - многофункциональный. Параллельно с поиском-заменой по телу DOC-файла, он ещё и создаёт в папке Images/ новые картинки в формате BMP (если оригинальный связанный файл был в ином, нежели BMP, формате). Правда, в не очень высоком разрешении, в каком - одному Robohelp понятно, но это разрешение ВСЕГДА ниже чем у оригинальных файлов. Все эти BMP картинки (как {bmc Images/реальное_имя картинки_в_папке.bmp}, так и автонумерованные) - потом точно в таком же виде, с теми же именами, в виде JPG или GIF файлов (это уже пользователь решает), будут использованы в HTML-help'е. Самое неприятное, что иногда (непонятно почему?) макрос ConvertDocument от Adobe Robohelp, вообще тупит - запись {bmc Images/реальное_имя картинки_в_папке.bmp} или {bmc IMG00001.bmp} ВООБЩЕ НЕ ПОЯВЛЯЕТСЯ в теле документа...
Теперь наверное понятно, зачем мне понадобился подобный макрос?
1) если одинаковые связанные картинки встречаются неоднократно в теле документа, неуправляемый макрос Robohelp'а включает очень неудобную автонумерацию. Когда картинок много, ручная замена их имён с {bmc IMG0000N.bmp} на {bmc Images/реальное_имя картинки_в_папке.bmp} впоследствии очень трудоёмка.
2) Имея подобный макрос, достаточно самому проследить, чтобы в папке Images находились только BMP-файлы, нужного размера и разрешения, имеющие понятное имя... Записи об этом в виде {bmc Images/реальное_имя картинки_в_папке.bmp} уже будут созданы.
Возможно я кого-то озадачил таким длинным постом, извините! Заранее благодарен, если уважаемые авторы проекта мне что-то посоветуют в этом направлении. Кстати, подобная моей проблема обсужждалась другими людьми на сайте Adobe, но - как видим - на текущий момент не разрешена: http://forums.adobe.com/message/2428453
В общем, пока решил свою задачку так:
Сперва выполняю перебор InlineShapes и перед каждым из найденных объектов, записываю нужную текстовую строку.
Вот такой код (за основу я взял Example2 на http://markros.ru/graphics/ ) :
Воспользовался там же процедурой CountInShps.
Шаг1.
Sub FindAndReplaceAllInlineShapes() 'Пример: перебор объектов InlineShape в цепочках документа 'Вычисляется число объектов InlineShape в цепочках документа 'Объекты InlineShape в надписях, расположенных в колонтитулах, 'не учитываются, поскольку не содержатся в цепочках 'Перед найденными объектами InlineShape записывается строка вида {bmc 'SourceFileFullName'} 'Найденные объекты InlineShape удаляются Dim intInlShpCount As Integer 'Счетчик InlineStory Dim rngStory As Range 'range для текущей цепочки в цикле Dim inlShape As InlineShape 'текущий объект InlineShape в цикле intInlShpCount = 0 'Цикл по каждому типу цепочек активного документа For Each rngStory In ActiveDocument.StoryRanges 'цикл по всем цепочкам одинакового типа Do 'в диапазоне цепочки rngStory на каждой итерации For Each inlShape In rngStory.InlineShapes inlShape.Range.InsertBefore ("{bmc " & inlShape.LinkFormat.SourceFullName & "}") intInlShpCount = intInlShpCount + 1 Next inlShape 'переход к следующей цепочке rngStory того же типа Set rngStory = rngStory.NextStoryRange Loop Until rngStory Is Nothing Next rngStory MsgBox "Всего заменено объектов InlineShape: " & intInlShpCount, vbInformation, "Перебор объектов InlineShape во всех цепочках" End SubЗатем - просто удаляю все объекты типа InlineShape (т.к. они теперь уже не нужны).
Шаг2.
Возможно, не совсем оптимальное решение - но оно работает.
Ещё раз, благодарю Вас, Марк Розенберг, за Ваши чрезвычайно полезные разработки!
Да, это все здорово, особенно когда количество документов переваливает за сотню. Поэтому все авторам - респект
Но обычно требуется замена в 2-10 документах. Для этого вовсе не обязательно использовать сторонние средства, а само решение весьма банально:
+ Выделяем и открываем все документы, в которых требуется произвести замену.
+ В последней открывшемся документе нажимаем Ctrl+H - появится стандартное диалоговое окно поиска и замены, в нем задаем все необходимые условия.
+ Нажимаем Заменить все для замены в текущем документе. Сохраняем и закрываем документ, не закрывая (!) при этом окно поиска и замены, после чего переключаемся на следующий окрытый документ (Ctrl+F6).
+ В следующем документе для нас уже отображено предыдущее диалоговое окно поиска и замены со всем заданными условиями - остается только нажать Заменить все.
+ ...
PS. Хочу подчеркнуть, что стандартный механизм поиска и замены в Word достаточно мощный (например, использование подстановочных символов и поиска по стилями/форматам может значительно сократить трудозатраты), поэтому использование сторонних средств и макросов не всегда оправдано.
Здравствуйте!
Спасибо большое за отличный макрос!
После долгих поисков нашла почти то, что нужно. Правда, мне очень необходим счетчик количества сделанных замен (а точнее, замены и не нужны, требуется просто посчитать слова). В обсуждении промелькнула информация о сделанном "усовершенствовании" макроса с наличием счетчика, но ссылка не сохранилась. Если бы кто-нибудь смог мне помочь, это было бы очень здорово!
Спасибо,
Аня.
почта ann.korobkova собака мэйл ру
Помогите, я в макросах полный ноль.
Проблема в том, что не могу заменить ссылки в документах (.doc .docx).
Укажите, пожалуйста, где я делаю ошибку:
1. Указываю папку
2. В таблице пишу слева "lkjl@sdf.ru" и справа "oip@pio.ua"
3. Нажимаю пуск, ставлю галку на "изменять гиперссылки".
Программа все делает без сбоев, вроде как заменяет, в логе прописаны все замененные файлы. Но когда открываю файл - старая ссылка на месте.
Может я чего не знаю, или с ссылками нужно поступать как-то иначе?
ЧеКа, пришлите мне документ на почтовый ящик viter.alex@gmail.com и я проверю, что не срабатывает. Правда, только в воскресенье, не раньше.
Спасибо за оперативный ответ.
Не совсем понял, какой документ присылать. Если имеется в виду документ, содержащий макрос, то пришлю (хотя там ведь ничего не менялось вроде как - смысл?).
Если Вы имели в виду документы, по которым ведется поиск - так таких документов тысячи. Но для примера могу выслать пару, если это поможет.
Заранее спасибо за помощь.
Конечно, пришлите пример документа, по которому ведётся поиск.
Все выслал перед выходными (19.05).
После перезагрузки (точнее уже сегодня, в понедельник) обнаружил, что ссылки поменялись, только криво: явная ссылка krasn-osv@rambler.ru поменялось на поле {HYPERLINK "mailto:osvitakr@ukr.net"}.
При этом копируется это поле как текст krasn-osv@rambler.ru (то есть при попытке вставить его сюда выдало прежний адрес).
Есть два предположения: 1. при установке офиса я не установила какой-то нужный для работы макроса компонент. 2. Эта проблема касается почтовых ссылок (может у них свои заморочки?)
Извините, если мои предположения - бред. Это от полного незнания материала.
Может, существует более простая возможность поменять эту злополучную ссылку на обычный текст? Для данной ситуации меня бы такой вариант устроил...
Нашлось ли какое-нибудь решение описанной проблемы?
Спасибо
Очень нужный макрос.
Только у меня установлен Word 2010 x64 и как только нажимаешь кнопку "Пуск" выпадает сообщение об ошибке. Просит обновить макрос под х64.
Может быть можно как-то исправить эту проблему?
Шикарно, спасибо, спасли огромную кучу времени.
Большое спасибо!
Спасибо, он РАБОТАЕТ!
3 часа работы руками и всего 5 минут на оставшейся объем после запуска макроса.
Красота!
Огромное спасибо!
Коллегит на 2010 64х не пашет .. что поправить ?
Очень нужно на 64-ку!
Добрый день!
У меня есть подобный макрос, только он заменяет в текущем открытом документе по списку слов из таблички в экселевском файле.
1. Есть ли возможность делать замену не с помощью стандартного "поиск и замена", а напрямую из макроса?
2. Можно ли делать замену сразу по всем блокам?
Сейчас макрос у меня пробегает более 400 строк таблички, и для каждой строки перебирает 100 блоков... очень долго получается.
* а прогресс-бар надо у вас позаимствовать ))
если кто знает ответ на мои вопросы - напишите на megadrifter (sobaka) gmail.com пожалуйста.
А скажите пожалуйста "чайнику" как нажать в SrcAndRpl_Beta3.doc кнопки "Пуск" и "Выбрать папку"???? и можно ли сделать изменения в документах в одной папке, в которой находятся ещё много папок, а в них и находятся эти документы, в которых надо сделать изменения????? Пожалуйста помогите!!! Надо очень срочно сделать изменения во многих доках, физически ничего не успеваю!!! Спасибо всем за отклик!!!!
Макрос работает хорошо, все что необходимо выполнил. Единственное, макрос тормозил на файлах которые попали под маску и находятся в "захваченном" состоянии (к ним нет доступа) речь едет о файлах ~$хххх.doc. Желательно сделать проверку на доступность файла при открытии.
Да на 32-ух битной винде работает превосходно скрипт, а вот с 64-ех реально проблемы. Я так понял в начале там подключается 32-ух битная библиотека (или что то такое). с префиксом _32
Думаю многие пользватели скажут спасибо, если автор сможет сделать версию и для 64-ех битного Word
Спасибо! Очень полезная штука.
Сделал все, что хотел: "найти и заменить в нескольких файлах *.doc*".
Заменяет слово или список слов во всех файлах, находящихся в одной указанной папке.
Заменять выражения пока не пробовал.
Супер!
Здравствуйте. Пытался заменить словосочетания в документе Word с помощью VolRepl и SrcAndRpl_Beta3. Большое предложение разбивал на несколько частей. часть словосочетаний меняется часть нет. Что может быть причиной.
а) Не хватает подробной информации в логе: сколько замен сделано, сколько и каких строк найдено.
б) Нужен то ли запрос нf запись итогового файла, то ли предусмотреть бэкап.
в) Хотелось бы поиска/замены с использованием регулярных выражений: например, мне надо не просто найти строки, а убить их, не оставляя пустых абзацев. Найти строки и заменить на них же, но с добавлением своей строки. Найти и заменить формат. Ну и всё остальное, что может показаться "бешенством с жиру".
А в предложенном варианте работает как зверь. Автору респект!
Ожидается ли появление в макросе выше перечисленных возможностей ?
Возможно ли сделать замену символа из греческого на букву русского алфавита ?
Всем Салют!
Сперва хочется поблагодарить автора за столь полезную и незаменимую в работе вещь! Спасибо мужик)
Но у меня возник мучительный вопрос...
во втором пункте (где надо забивать заменяемый текст) можно ли как то использовать несколько строк заменяего текста.. к примеру:
Искать текст Заменить на текст:
1)Адрес: Шишкина ул., д. 18 1)Адрес: Братеевская ул., д. 105
2)Центр образования № 108 2) Гимназия 1005
можно ли проделать этот трюк столбиком , чтобы мне не пришлось создавать несколько макросов на каждое заменяемое слово?
хочется сделать РЫБУ по умолчанию из определенных слов, которые я заменял бы в столбце на то что нужно
Здраствуйте! спасибо Вам за такой макрос, но у меня такая ошибка, я пытаюсь в выбраных документах заменить выбраный текст, на большой текст, и мне пишет ошибка, слишком долгий текстовый формат. Подскажите как справиться с этой ошибкой. Заранее спасибо
Добрый день. Большое спасибо за макрос, очень полезная вещь! но обнаружилась такая проблема: делаю замену в файлах *.dot, внизу каждой страницы добавляются колонтитулы, из-за чего нарушается структура документов и всё равно приходится их потом доводить до ума вручную
Скажите, а можно сделать так, что бы в вставляемом тексте учитывались надстрочные и подстрочные символы? К примеру, знак степени числа
Макрос крайне полезный, но у меня тут же ругнулся на то, что у меня 64-битная система
Спасибо Александру Витеру за макрос по замене в док-ах Word. Но почему-то невозможно выбрать путь, а также что на что меняем. Путь пришлось создать такой как по умолчанию. В файле отчета написано что заменено слово testdone на test. В моих файлах файлах слово testdone отсутствовало, но когда я его туда вписал, то замена была выполнена. Что надо сделать, чтобы путь и слова можно было бы выбирать из окна запущенного макроса. Я сделал скрин, но куда отправить?
Чтобы работало на 64-битной системе нужно изменить строчку
Private Declare Function GetTickCount Lib "kernel32" () As Long
на
Private Declare PtrSafe Function GetTickCount Lib "kernel32" () As Long
Но в колонтитулах так и не ищёт, если кто-то поделится версией, которая обрабатывает колонтитулы, буду благодарен, а то все ссылки не рабочие.
Спасибо Александр за макрос. Необходимо заменить 3 абзаца на 1. Ошибка run time error 5854. Можно ли е обойти?
В дополнение к комментарию №67 http://wordexpert.ru/page/makros-paketnoj-zameny-ot-aleksandra-vitera#comment-7095.
Для универсальности кода в части 64х/32х битной системы и Office 2010-2013/Office 20103-2007
нужно изменить строчку
Private Declare Function GetTickCount Lib "kernel32" () As Long
на
#If VBA7 Then ' Office 2010-2013
Private Declare PtrSafe Function GetTickCount Lib "kernel32" () As LongPtr
#Else ' Office 2003-2007
Private Declare Function GetTickCount Lib "kernel32" () As Long
#End If
а также
Dim nTimeCntr As Long 'Счетчик времени обработки
на
Dim nTimeCntr As LongPtr 'Счетчик времени обработки
Добрый день!
Есть ли возможность перед словом вставить рисунок. В смысле в нескольких сотнях документов. Если есть - подскажите, если нет - тоже скажите.
С уважением..
Огромное спасибо за макрос. При эксплуатации возникла следующая проблема: при замене номеров сносок, которые оформляются верхним регистром, сноски превращались в обычные цифры, без верхнего регистра. Есть ли возможность обойти эту проблему.
Спасибо за макрос, очень интересная и полезная вещь!
Не знаю, нужны ли автору сообщения об ошибках, но вот, извольте
Как известно в Word'e можно ставить пробел, удерживая ctrl+shift. В таком случае следующее слово не перенесется на следующую строку или перенесется вместе с предыдущим. Эта функция довольно часто используется в документах, например, чтобы инициалы человека не переносились отдельно от фамилии.
Так вот, при тестировании макроса обнаружил, что макрос не производит замену, если в предложении есть такие пробелы, при чем независимо от параметров (формата) вставки.
Да, кстати, поддерживаю предыдущих комментаторов насчет ограничения по длине текста. Весьма хотелось бы заменять большие куски текста.
Работает на удивление отлично. Есть один непонятный момент: если меняется часть текста, в которой первая половина жирным шрифтом, а вторая - обычным, то итог замены получается весь жирным. Может, я что-то не так делаю?
Если в документе два разных колонтитула, макрос производит замену только в первом, что нужно изменить в макросе, что бы он смотрел все колонтитулы?
Добрый Вечер!
А можно сделать так, чтобы измененый файл сохранялся отдельно а файл который был открыть оставался неизменным?
http://wordexpert.ru/page/makros-paketnoj-zameny-ot-aleksandra-vitera#comment-6582
Подтверждаю проблему с добавлением колонтитулов и в итоге меняется структура
Здравствуйте, может кто подскажет макрос в ворде, чтобы мог например менять в тексте имя на нужное типо в тексте везде написано слово правительство а нужно автоматом изменить везде на государство
Спасибо
Код для работы 32/64. Нашел в гугле. Работает
#If Win64 Then
Private Declare PtrSafe Function GetTickCount Lib "kernel32" () As Long
#Else
Private Declare Function GetTickCount Lib "kernel32"() As Long
#End If
Вы гений!!!!!!Офигенно!!!!!!!
Александр!
Огромное спасибо за этот макрос замены.
Он позволил сэкономить массу времени.
Здоровья Вам и удачи во всём!
Раньше пользовался, было хорошо. Но сейчас очень пахабит файлы (то ли винда 10 виновата, то ли новый ворд, не знаю).
Спасибо. Очень полезная штука!
Маленький баг - колонтитулы в исправленных документах отодвигает, поэтому текст смещается.
Автору спасибо за данный труд!!!
Добрый день. Макрос очень полезный. Вопрос: можно преобразовать макрос так, чтобы он открывал файлы ВОРД в одной папке и сохранял их как ПДФ ?
То есть начало такое же:
1. в файле ВОРД выбирается путь к папке;
2. при нажатии на кнопку "Пуск" выполняется следующий макрос:
Sub ConvertWordsToPdfs()
Dim xIndex As String
Dim xDlg As FileDialog
Dim xFolder As Variant
Dim xNewName As String
Dim xFileName As String
Set xDlg = Application.FileDialog(msoFileDialogFolderPicker)
If xDlg.Show -1 Then Exit Sub
xFolder = xDlg.SelectedItems(1) + "\"
xFileName = Dir(xFolder & "*.*", vbNormal)
While xFileName ""
If ((Right(xFileName, 4)) ".doc" Or Right(xFileName, 4) ".docx") Then
xIndex = InStr(xFileName, ".") + 1
xNewName = Replace(xFileName, Mid(xFileName, xIndex), "pdf")
Documents.Open FileName:=xFolder & xFileName, _
ConfirmConversions:=False, ReadOnly:=False, AddToRecentFiles:=False, _
PasswordDocument:="", PasswordTemplate:="", Revert:=False, _
WritePasswordDocument:="", WritePasswordTemplate:="", Format:= _
wdOpenFormatAuto, XMLTransform:=""
ActiveDocument.ExportAsFixedFormat OutputFileName:=xFolder & xNewName, _
ExportFormat:=wdExportFormatPDF, OpenAfterExport:=False, OptimizeFor:= _
wdExportOptimizeForPrint, Range:=wdExportAllDocument, From:=1, To:=1, _
Item:=wdExportDocumentContent, IncludeDocProps:=True, KeepIRM:=True, _
CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _
BitmapMissingFonts:=True, UseISO19005_1:=False
ActiveDocument.Close
End If
xFileName = Dir()
Wend
End Sub
Огромная благодарность автору за невероятную экономию времени, а Максиму за подсказку про Win 64