Доброго дня! Очень нужен макрос для выделения цветом слов в документе. Есть список слов порядка 100 шт. и он постоянно дополняется. И так же есть множество документов в которых слова из списка нужно либо исправить, либо удалить, либо оставить - на усмотрение редактирующего. Нашел такой: [vba]
Код
Sub PaintGrey() Selection.Find.ClearFormatting Options.DefaultHighlightColorIndex = wdRed Selection.Find.Replacement.ClearFormatting Selection.Find.Replacement.Highlight = True ' подсветка With Selection.Find .Text = "ght" ' текст для поиска .Replacement.Text = "ght" ' текст для замены .Forward = True .Wrap = wdFindContinue .Format = True .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Selection.Find.Execute Replace:=wdReplaceAll End Sub
[/vba] Но он мне не подходит, так как нужно под каждое слово, копировать часть макроса, вставлять слово 2 раза и так 100 раз((( Хотелось бы, что бы можно было их через запятую, что-ли написать и в любой момент дополнить если нужно.
Доброго дня! Очень нужен макрос для выделения цветом слов в документе. Есть список слов порядка 100 шт. и он постоянно дополняется. И так же есть множество документов в которых слова из списка нужно либо исправить, либо удалить, либо оставить - на усмотрение редактирующего. Нашел такой: [vba]
Код
Sub PaintGrey() Selection.Find.ClearFormatting Options.DefaultHighlightColorIndex = wdRed Selection.Find.Replacement.ClearFormatting Selection.Find.Replacement.Highlight = True ' подсветка With Selection.Find .Text = "ght" ' текст для поиска .Replacement.Text = "ght" ' текст для замены .Forward = True .Wrap = wdFindContinue .Format = True .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Selection.Find.Execute Replace:=wdReplaceAll End Sub
[/vba] Но он мне не подходит, так как нужно под каждое слово, копировать часть макроса, вставлять слово 2 раза и так 100 раз((( Хотелось бы, что бы можно было их через запятую, что-ли написать и в любой момент дополнить если нужно.svoyak
Сообщение отредактировал svoyak - Четверг, 31.08.2017, 08:00
Цитата svoyak, 31.08.2017 в 07:51, в сообщении № 1 ( писал(а)): либо исправить, либо удалить, либо оставить - на усмотрение редактирующего не понятно, как Вы хотите реализовать
Допустим у меня есть текст в котором слово "привет" есть 3 раза, слово "пока" - 2 раза, словосочетание "не менее" - 2 раза и так далее ещё 50 слов или больше. Так вот нужно, чтобы макрос просто выделил все эти слова ЦВЕТОМ за 1 нажатие и всё!
Pelena, Список слов пока в отдельном файле, а документы просто текстовый файл в word - смысла в нём не много будет
Цитата svoyak, 31.08.2017 в 07:51, в сообщении № 1 ( писал(а)): либо исправить, либо удалить, либо оставить - на усмотрение редактирующего не понятно, как Вы хотите реализовать
Допустим у меня есть текст в котором слово "привет" есть 3 раза, слово "пока" - 2 раза, словосочетание "не менее" - 2 раза и так далее ещё 50 слов или больше. Так вот нужно, чтобы макрос просто выделил все эти слова ЦВЕТОМ за 1 нажатие и всё!svoyak
Сообщение отредактировал svoyak - Четверг, 31.08.2017, 08:36
Sub PaintGrey() Dim xfind(), i& xfind = Array("привет", "пока", "не менее") Selection.Find.ClearFormatting Options.DefaultHighlightColorIndex = wdRed Selection.Find.Replacement.ClearFormatting Selection.Find.Replacement.Highlight = True ' подсветка For i = 0 To UBound(xfind) With Selection.Find .Text = xfind(i) ' текст для поиска .Replacement.Text = xfind(i) ' текст для замены .Forward = True .Wrap = wdFindContinue .Format = True .MatchCase = False .MatchWholeWord = True .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Selection.Find.Execute Replace:=wdReplaceAll Next i End Sub
[/vba]
[vba]
Код
Sub PaintGrey() Dim xfind(), i& xfind = Array("привет", "пока", "не менее") Selection.Find.ClearFormatting Options.DefaultHighlightColorIndex = wdRed Selection.Find.Replacement.ClearFormatting Selection.Find.Replacement.Highlight = True ' подсветка For i = 0 To UBound(xfind) With Selection.Find .Text = xfind(i) ' текст для поиска .Replacement.Text = xfind(i) ' текст для замены .Forward = True .Wrap = wdFindContinue .Format = True .MatchCase = False .MatchWholeWord = True .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Selection.Find.Execute Replace:=wdReplaceAll Next i End Sub
Если слов много, можно их в отдельный файл выписать в столбик и такой макрос применить. Файл список слов должен находиться в той же папке [vba]
Код
Sub PaintGrey() Dim xfind(), xrepl(), i& Dim WDoc As Object Dim pr As Paragraph Set WDoc = Documents.Open(ThisDocument.Path & "\" & "список слов.docx") For Each pr In ActiveDocument.Paragraphs i = i + 1 ReDim Preserve xfind(1 To i) xfind(i) = Left(pr.Range.Text, Len(pr.Range.Text) - 1) Next pr WDoc.Close ThisDocument.Activate Selection.Find.ClearFormatting Options.DefaultHighlightColorIndex = wdRed Selection.Find.Replacement.ClearFormatting Selection.Find.Replacement.Highlight = True ' подсветка For i = 1 To UBound(xfind) With Selection.Find .Text = xfind(i) ' текст для поиска .Replacement.Text = xfind(i) ' текст для замены .Forward = True .Wrap = wdFindContinue .Format = True .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Selection.Find.Execute Replace:=wdReplaceAll Next i End Sub
[/vba]
Если слов много, можно их в отдельный файл выписать в столбик и такой макрос применить. Файл список слов должен находиться в той же папке [vba]
Код
Sub PaintGrey() Dim xfind(), xrepl(), i& Dim WDoc As Object Dim pr As Paragraph Set WDoc = Documents.Open(ThisDocument.Path & "\" & "список слов.docx") For Each pr In ActiveDocument.Paragraphs i = i + 1 ReDim Preserve xfind(1 To i) xfind(i) = Left(pr.Range.Text, Len(pr.Range.Text) - 1) Next pr WDoc.Close ThisDocument.Activate Selection.Find.ClearFormatting Options.DefaultHighlightColorIndex = wdRed Selection.Find.Replacement.ClearFormatting Selection.Find.Replacement.Highlight = True ' подсветка For i = 1 To UBound(xfind) With Selection.Find .Text = xfind(i) ' текст для поиска .Replacement.Text = xfind(i) ' текст для замены .Forward = True .Wrap = wdFindContinue .Format = True .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Selection.Find.Execute Replace:=wdReplaceAll Next i End Sub
Pelena, подскажите что я делаю не так. со скриптами встретился впервые. первый ваш вариант добавил в ворд2016, работает отлично. но со вторым проблема. Выдаёт ошибку Run-time error '91': Object variable or With block variable not set пробовал копировать скрипт и копировать файл "список слов.docx", всегда ошибка.
Pelena, подскажите что я делаю не так. со скриптами встретился впервые. первый ваш вариант добавил в ворд2016, работает отлично. но со вторым проблема. Выдаёт ошибку Run-time error '91': Object variable or With block variable not set пробовал копировать скрипт и копировать файл "список слов.docx", всегда ошибка.serejaa
Как же я могу подсказать, если не вижу Ваши файлы? По картинке лечить не умею. Ошибка Object variable or With block variable not set говорит о том, что объектная переменная не определена. В макросе только одна объектная переменная WDoc. Значит, проблемы с открытием файла список слов.docx Проверила свои файлы из сообщения 12 на Excel 2016, у меня макрос сработал
Как же я могу подсказать, если не вижу Ваши файлы? По картинке лечить не умею. Ошибка Object variable or With block variable not set говорит о том, что объектная переменная не определена. В макросе только одна объектная переменная WDoc. Значит, проблемы с открытием файла список слов.docx Проверила свои файлы из сообщения 12 на Excel 2016, у меня макрос сработалPelena
"Черт возьми, Холмс! Но как??!!" Ю-money 41001765434816
Pelena, работать с Вашим первым вариантом оказалось на много удобнее, но подскажите пожалуйста можно ли сделать так, чтобы поиск был не по конкретному слову, а по корню слова. Т.е. чтобы выделялись не только описанные слова, а все слова где указанный корень встречается.
[vba]
Код
Sub PaintYellow() Dim xfind(), i& xfind = Array("привет", "пока", "менее") Selection.Find.ClearFormatting Options.DefaultHighlightColorIndex = wdYellow Selection.Find.Replacement.ClearFormatting Selection.Find.Replacement.Highlight = True ' подсветка For i = 0 To UBound(xfind) With Selection.Find .Text = xfind(i) ' текст для поиска .Replacement.Text = xfind(i) ' текст для замены .Forward = True .Wrap = wdFindContinue .Format = True .MatchCase = False .MatchWholeWord = True .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Selection.Find.Execute Replace:=wdReplaceAll Next i End Sub
[/vba]
Pelena, работать с Вашим первым вариантом оказалось на много удобнее, но подскажите пожалуйста можно ли сделать так, чтобы поиск был не по конкретному слову, а по корню слова. Т.е. чтобы выделялись не только описанные слова, а все слова где указанный корень встречается.
[vba]
Код
Sub PaintYellow() Dim xfind(), i& xfind = Array("привет", "пока", "менее") Selection.Find.ClearFormatting Options.DefaultHighlightColorIndex = wdYellow Selection.Find.Replacement.ClearFormatting Selection.Find.Replacement.Highlight = True ' подсветка For i = 0 To UBound(xfind) With Selection.Find .Text = xfind(i) ' текст для поиска .Replacement.Text = xfind(i) ' текст для замены .Forward = True .Wrap = wdFindContinue .Format = True .MatchCase = False .MatchWholeWord = True .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Selection.Find.Execute Replace:=wdReplaceAll Next i End Sub
Sub PaintGrey() Dim xfind(), i& xfind = Array("привет", "пока", "не менее") Selection.Find.ClearFormatting Options.DefaultHighlightColorIndex = wdRed Selection.Find.Replacement.ClearFormatting Selection.Find.Replacement.Highlight = True ' подсветка For i = 0 To UBound(xfind) With Selection.Find .Text = xfind(i) ' текст для поиска .Replacement.Text = xfind(i) ' текст для замены .Forward = True .Wrap = wdFindContinue .Format = True .MatchCase = False .MatchWholeWord = True .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Selection.Find.Execute Replace:=wdReplaceAll Next i End Sub
Pelena, подскажите пожалуйста что сделать, если список слов не помещается в 1 строку в макросе?
Sub PaintGrey() Dim xfind(), i& xfind = Array("привет", "пока", "не менее") Selection.Find.ClearFormatting Options.DefaultHighlightColorIndex = wdRed Selection.Find.Replacement.ClearFormatting Selection.Find.Replacement.Highlight = True ' подсветка For i = 0 To UBound(xfind) With Selection.Find .Text = xfind(i) ' текст для поиска .Replacement.Text = xfind(i) ' текст для замены .Forward = True .Wrap = wdFindContinue .Format = True .MatchCase = False .MatchWholeWord = True .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Selection.Find.Execute Replace:=wdReplaceAll Next i End Sub
Чтобы разбить строку в макросе, надо в конце поставить пробел, знак подчеркивания и нажать Enter, тогда следующая строка будет продолжением предыдущей. Или посмотрите вариант в сообщении 12
Чтобы разбить строку в макросе, надо в конце поставить пробел, знак подчеркивания и нажать Enter, тогда следующая строка будет продолжением предыдущей. Или посмотрите вариант в сообщении 12Pelena
"Черт возьми, Холмс! Но как??!!" Ю-money 41001765434816