Страницы: 1
RSS
Word. Макрос "Найти и заменить" - Как сократить
 
Доброго времени суток, люди добрые!

Помогите пожалуйста, если есть такая возможность.
Цель - найти и заменить один текст на другой в документе.
Реализация ниже, это стандартный макрос при "Запись макроса...." через функцию "Найти и заменить", проблема в том, что таких замен у меня более 3000 шт. и в один макрос не влезает приходиться разбивать на три и более.

Может есть возможность сократить этот или написать похожее?
Код
Selection.Find.ClearFormatting
     Selection.Find.Replacement.ClearFormatting
     With Selection.Find
       .Text = "111"
       .Replacement.Text = "222"
         .Forward = True
         .Wrap = wdFindContinue
         .Format = False
         .MatchCase = False
         .MatchWholeWord = False
         .MatchWildcards = False
         .MatchSoundsLike = False
         .MatchAllWordForms = False
End With
     Selection.Find.Execute Replace:=wdReplaceAll
     With Selection.Find
       .Text = "111"
       .Replacement.Text = "222"
         .Forward = True
         .Wrap = wdFindContinue
         .Format = False
         .MatchCase = False
         .MatchWholeWord = False
         .MatchWildcards = False
         .MatchSoundsLike = False
         .MatchAllWordForms = False
End With
Заранее благодарю всех заинтересованных лиц!
Изменено: vikttur - 10.06.2021 12:36:33
 
идите в сторону внешнего "словаря"

Есть у меня наработка, может подойдет, может под себя перепишете, может идеи подчерпнете.

Закоментил в коде что помнил для чего
Данные  подстановок берет с гуглтаблицы
(https://docs.google.com/spreadsheets/d/1pxpfVix9vAVBFYCvMdANBgdTnXFHSkW3tZX6iya1­lUs
как пример показать, нужен открытый доступ по ссылке, пример свой с гуглтаблицы удалю через недельку или как вспомню о нем)
(не нужно в облаке - перепишете на локальны файл)

PS: за корявый код прошу сильно не пинать ;)
Код
Option Explicit

Sub TestReplace()
Application.ScreenUpdating = False
'открываем и читаем гуглтаблицу, нужен открытый доступ по ссылке'
Dim sAddress As String, sData
    Workbooks.OpenText Filename:="https://docs.google.com/spreadsheets/d/1pxpfVix9vAVBFYCvMdANBgdTnXFHSkW3tZX6iya1lUs/export?format=tsv", Origin:=65001, Tab:=True
    sAddress = "A1:B10000" 'адреса в словаре'
    'получаем значения'
    sData = Range(sAddress).Value
    ActiveWorkbook.Close False
    'Записываем данные на активный лист книги, с которой запустили макрос, где-то сбоку в области без данных'
    If IsArray(sData) Then
        [AD1].Resize(UBound(sData, 1), UBound(sData, 2)).Value = sData
    Else
        [AD1] = sData
    End If
'блок подстановок'
Dim lLastRowA As Long, lLastRowB As Long, TekRowA As Long, TekRowB As Long, NT As String
lLastRowA = Cells(Rows.Count, "A").End(xlUp).Row 'столбец исходный текст оригинала'
lLastRowB = Cells(Rows.Count, "AD").End(xlUp).Row 'столбец соответствующие подстановки словаря'
For TekRowA = 1 To lLastRowA
NT = Replace(Cells(TekRowA, 1), Cells(30, 30), Cells(30, 31), , , vbTextCompare) 'номера столбцов с исходными данными и данными словаря'
If lLastRowB > 1 Then
For TekRowB = 1 To lLastRowB
NT = Replace(NT, Cells(TekRowB, 30), Cells(TekRowB, 31), , , vbTextCompare)
Next TekRowB
End If
Cells(TekRowA, 1) = NT 'номер столбца для вставки результата'
Next TekRowA
'удаляем считанные со словаря данные'
Columns("AD:AE").Delete
Application.ScreenUpdating = True
End Sub


Изменено: andylu - 10.06.2021 12:01:12
 
Очень странно, что Вы не упоминаете маленький факт - это Word. И забыли в принципе показать - нужно все найденное на одно и то же значение менять или на разные.
Код
Dim lr&, aFnd, aRep
aFnd = Array("111","222")
aRep = Array("1","2")
For lr = lbound(aFnd) to ubound(aFnd)
     Selection.Find.ClearFormatting
     Selection.Find.Replacement.ClearFormatting
     With Selection.Find
       .Text = aFnd(lr)
       .Replacement.Text = aRep(lr)
         .Forward = True
         .Wrap = wdFindContinue
         .Format = False
         .MatchCase = False
         .MatchWholeWord = False
         .MatchWildcards = False
         .MatchSoundsLike = False
         .MatchAllWordForms = False
End With
Next
Изменено: Дмитрий(The_Prist) Щербаков - 10.06.2021 12:01:23
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
andylu, огромное спасибо, такое в любом случае пригодиться!

Дмитрий(The_Prist) Щербаков, прошу прощение, не думал что могут быть разные макросы для эксель и ворд.
По поводу значений, менять на разные ("Order" поменять только на "Заказ", а "DF125" поменять только на "Смеситель с рычагом")
Вам тоже спасибо за макрос, попробую в нем разобраться.
Изменено: vikttur - 10.06.2021 12:35:47
 
Цитата
Максим Сухарев написал:
попробую в нем разобраться
там нечего особо разбираться. Меняете значения в массивах:
Код
aFnd = Array("111","222")
aRep = Array("1","2")
В данной строке каждое значение "111" будет заменено на "1", а "222" на "2". Таким образом для
Цитата
Максим Сухарев написал:
"Order" поменять только на "Заказ", а "DF125" поменять только на "Смеситель с рычагом"
строки должны выглядеть так:
Код
aFnd = Array("Order","DF125")
aRep = Array("Заказ","Смеситель с рычагом")
Принцип должен быть интуитивно понятен.
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
Спасибо всем участвующим.

С помощью всех, получился данный код. (с ним сейчас и работаю)


Код
Dim arrText() As Variant
arrText = Array("1", "3")

Dim arrReplaceText() As Variant
arrReplaceText = Array("2", "5")

Selection.WholeStory

For i = 0 To UBound(arrText)

 Selection.Find.ClearFormatting
 Selection.Find.Replacement.ClearFormatting
 With Selection.Find
 .Text = arrText(i)
 .Replacement.Text = arrReplaceText(i)
 .Forward = True
 .Wrap = wdFindContinue
 .Format = False
 .MatchCase = False
 .MatchWholeWord = False
 .MatchWildcards = True
 .MatchSoundsLike = False
 .MatchAllWordForms = False
 End With
 Selection.Find.Execute Replace:=wdReplaceAll
Next
 
Максим Сухарев,
а массовый ввод данных для подстановок как-то организовали?
(варианты реализации интересны)

3 с лишним тысячи через код вписать если разово то еще допустим можно, а если списки замен меняются/будут меняться, то как минимум неудобство отыскать соответствие где-то в середине длинющих arrText + arrReplaceText.
 
andylu
Вчера пол дня танцевал с эти кодом и да, не очень удобно при наличии 3000 замен.
Буду пытаться соединить с Вашим кодом а именно имитации "ВПР" через внешний словарь)))
Боюсь моих знаний на это не хватит(
Страницы: 1
Наверх