Помогите пожалуйста, если есть такая возможность. Цель - найти и заменить один текст на другой в документе. Реализация ниже, это стандартный макрос при "Запись макроса...." через функцию "Найти и заменить", проблема в том, что таких замен у меня более 3000 шт. и в один макрос не влезает приходиться разбивать на три и более.
Может есть возможность сократить этот или написать похожее?
Есть у меня наработка, может подойдет, может под себя перепишете, может идеи подчерпнете.
Закоментил в коде что помнил для чего Данные подстановок берет с гуглтаблицы (https://docs.google.com/spreadsheets/d/1pxpfVix9vAVBFYCvMdANBgdTnXFHSkW3tZX6iya1lUs как пример показать, нужен открытый доступ по ссылке, пример свой с гуглтаблицы удалю через недельку или как вспомню о нем) (не нужно в облаке - перепишете на локальны файл)
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
Очень странно, что Вы не упоминаете маленький факт - это 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
andylu, огромное спасибо, такое в любом случае пригодиться!
Дмитрий(The_Prist) Щербаков, прошу прощение, не думал что могут быть разные макросы для эксель и ворд. По поводу значений, менять на разные ("Order" поменять только на "Заказ", а "DF125" поменять только на "Смеситель с рычагом") Вам тоже спасибо за макрос, попробую в нем разобраться.
Максим Сухарев, а массовый ввод данных для подстановок как-то организовали? (варианты реализации интересны)
3 с лишним тысячи через код вписать если разово то еще допустим можно, а если списки замен меняются/будут меняться, то как минимум неудобство отыскать соответствие где-то в середине длинющих arrText + arrReplaceText.
andylu Вчера пол дня танцевал с эти кодом и да, не очень удобно при наличии 3000 замен. Буду пытаться соединить с Вашим кодом а именно имитации "ВПР" через внешний словарь))) Боюсь моих знаний на это не хватит(