Страницы: 1
RSS
Макрос для поиска и замены текста в ячейках согласно списка
 
Добрый день!

Прошу Вашей помощи!
В примере есть лист 1 - Specification, в первом столбце(его положение может меняться, поэтому лучше использовать выделенный диапазон) слова с ошибками, в них нужно исправить ошибки с помощью замены, из листа 2 - ReplaceList, в нём два столбца, в первом слова с ошибками, во втором правильный, он будет постоянно дополняться.

Нужен макрос, который бы находил и заменял текст в выделенном диапазоне ячеек согласно списку, объем достаточно большой от 2 500 до 10 000 ячеек.

Буду очень благодарен за помощь!

Спасибо!
 
argyman, вот вариант:
Код
Sub replaceByList()
    Dim replaceRn As Range, inputRn As Range, replacementsRn As Range
    ' Определяем диапазон со значениями для замен
    With ThisWorkbook.Sheets("ReplaceList")
        Set replacementsRn = Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp).Offset(0, 1))
    End With
    With ThisWorkbook.Sheets("Specification")
        ' Устанавливаем стартовый диапазон
        Set replaceRn = Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp))
        ' Выделяем стартовый диапазон
        replaceRn.Parent.Activate
        replaceRn.Select
        ' Выведем запрос на изменение диапазона
        On Error Resume Next
        Set inputRn = Application.InputBox( _
                        Prompt:="Адрес для массовой замены", _
                        Title:="Замена по списку", _
                        Default:=replaceRn.Address(True, True, xlA1, True), _
                        Type:=8)
        Err.Clear
        On Error goto 0
        ' Если пользователь отменил выделение - выйдем из макроса с предупреждением
        If Not inputRn Is Nothing Then
            Set replaceRn = inputRn
        Else
            MsgBox "Диапазон не выбран", vbCritical
            Exit Sub
        End If
    End With
    
    ' Для каждой пары заменяемых значений сделаем замену
    For Each rrow In replacementsRn.Rows
        replaceRn.Replace What:=rrow.Cells(1, 1).Value, Replacement:=rrow.Cells(1, 2).Value
    Next rrow
    
    ' Выведем сообщение о завершении работы (можно убрать)
    MsgBox "Done!", vbInformation
End Sub
Изменено: tolstak - 24.08.2018 14:24:14
In GoTo we trust
 
Еще вариант:
Код
Option Explicit

Sub test()
    Dim dic As Object, txt$
    Dim i&, arr()
    Set dic = CreateObject("Scripting.Dictionary")
    arr = Worksheets("ReplaceList").UsedRange.Value
    For i = 1 To UBound(arr)
        txt = arr(i, 1)
        dic.Item(txt) = arr(i, 2)
    Next i
    arr = Worksheets("Specification").UsedRange.Value
    For i = 1 To UBound(arr)
        txt = arr(i, 1)
        If dic.exists(txt) Then arr(i, 1) = dic.Item(txt)
    Next i
    Worksheets("Specification").[a1].Resize(UBound(arr), UBound(arr, 2)).Value = arr
End Sub
"Все гениальное просто, а все простое гениально!!!"
 
tolstak, огромное Вам спасибо!
Отличное решение!
Именно то, что я и хотел!
 
Пример с выбором диапазона:

Код
Sub test()
'   ---------------------------------------------
    Dim dic As Object, i&, txt$
    Dim allrange As Range, rng As Range
'   ---------------------------------------------
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
    Set allrange = Application.InputBox("Выберите диапазон", Type:=8)
    arr = Worksheets("ReplaceList").UsedRange.Value
    For i = 1 To UBound(arr)
        txt = arr(i, 1)
        dic.Item(txt) = arr(i, 2)
    Next i
    For Each rng In allrange
        txt = rng.Value
        If dic.exists(txt) Then rng.Value = dic.Item(txt)
    Next rng
    Application.ScreenUpdating = True
End Sub
"Все гениальное просто, а все простое гениально!!!"
 
Nordheim, круто! спасибо большое!
 
А как можно дополнить данный код, чтобы рядом с таблицей значений на замену была таблица со значениями, при встрече которых строка бы удалялась полностью?
 
AngSem, можно вот так:
Код
Sub replaceByList()
    Dim replaceRn As Range, inputRn As Range, replacementsRn As Range
    Dim deletionRn As Range, delRn As Range
    
    ' Определяем диапазон со значениями для удаления и замен
    With ThisWorkbook.Sheets("ReplaceList")
        ' Значения для удаления
        Set deletionRn = Range(.Cells(2, 5), .Cells(.Rows.Count, 5).End(xlUp).Offset(0, 1))
        
        ' Значения для замены
        Set replacementsRn = Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp).Offset(0, 1))
    End With
    
    With ThisWorkbook.Sheets("Specification")
        ' Устанавливаем стартовый диапазон
        Set replaceRn = Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp))
        ' Выделяем стартовый диапазон
        replaceRn.Parent.Activate
        replaceRn.Select
        ' Выведем запрос на изменение диапазона
        On Error Resume Next
        Set inputRn = Application.InputBox( _
                        Prompt:="Адрес для массовой замены", _
                        Title:="Замена по списку", _
                        Default:=replaceRn.Address(True, True, xlA1, True), _
                        Type:=8)
        Err.Clear
        On Error GoTo 0
        ' Если пользователь отменил выделение - выйдем из макроса с предупреждением
        If Not inputRn Is Nothing Then
            Set replaceRn = inputRn
        Else
            MsgBox "Диапазон не выбран", vbCritical
            Exit Sub
        End If
    End With
    
' Поиск строк для УДАЛЕНИЯ
' Если удаление не требуется, кусок можно закомментировать
    ' Для каждой строки в анализируемых данных
    For Each ccell In inputRn.Cells
        ' Если ВПР(текущее значение;список_на_удаление;1;0) находит что-то, то
        If Not IsError(Application.VLookup(ccell.Cells(1).Value, deletionRn, 1, 0)) Then
            ' Добавим текущую строку к диапазону на удаление
            If delRn Is Nothing Then
                Set delRn = ccell.EntireRow
            ' Если в диапазоне на удаление уже что-то есть - допишем в него текущую строку
            Else
                Set delRn = Union(delRn, ccell.EntireRow)
            End If
        End If
    Next ccell
    ' Удалим диапазон, если он не пустой
    If Not delRn Is Nothing Then delRn.Delete
''
    
    
' Поиск строк для ЗАМЕНЫ
' Если удаление не требуется, кусок можно закомментировать
    
    ' Для каждой пары заменяемых значений сделаем замену
    For Each rrow In replacementsRn.Rows
        replaceRn.Replace What:=rrow.Cells(1, 1).Value, Replacement:=rrow.Cells(1, 2).Value
    Next rrow
''
    
    ' Выведем сообщение о завершении работы (можно убрать)
    MsgBox "Done!", vbInformation
End Sub


In GoTo we trust
 
Вопрос к tolstak,  а как в первом варианте сделать так чтобы значения в ячейках которые проверяются были жестко зафиксированы.
то есть в файле спецификации есть и aakrp и aakr  и aakr45

при нынешней обработке получается что  aakrp и  aakr45 преобразовываются в значение которое подставляется по синтаксису aakr  с концом от значения в виде P и 45
как залочить значения? что если в ячейке aakr45 то оно и будет менятся на то чему равно в спецификации.
Изменено: Andrey K - 12.06.2020 18:52:13
 
Andrey K, по идее, вот так:
Код
    ' Для каждой пары заменяемых значений сделаем замену
    For Each rrow In replacementsRn.Rows
        replaceRn.Replace What:=rrow.Cells(1, 1).Value, Replacement:=rrow.Cells(1, 2).Value, LookAt:=xlWhole
    Next rrow
    
In GoTo we trust
 
tolstak,Спасибо большое всё помогло! =) дальше уже сам доделал обратное объединение в строку.
 
Вопрос к tolstak,  а как в первом варианте делать замену и по условию: т.е если значение ячейки не начинается на Liftinq или на Antistat то замену выполняем , в противном случае оставляем значение ячейки без изменений  
 
ageres1982, вот так:
Код
Sub replaceByList()
    Dim replaceRn As Range, inputRn As Range, replacementsRn As Range
    ' Определяем диапазон со значениями для замен
    With ThisWorkbook.Sheets("ReplaceList")
        ' Фразы для замены
        Set replacementsRn = Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp).Offset(0, 1))
        ' Если ячейка начинается на эти слова - не делаем замену
        Set startingWordsToIgnoreRn = Range(.Cells(2, 4), .Cells(.Rows.Count, 4).End(xlUp))
    End With
    
    With ThisWorkbook.Sheets("Specification")
        ' Устанавливаем стартовый диапазон
        Set replaceRn = Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp))
        ' Выделяем стартовый диапазон
        replaceRn.Parent.Activate
        replaceRn.Select
        ' Выведем запрос на изменение диапазона
        On Error Resume Next
        Set inputRn = Application.InputBox( _
                        Prompt:="Адрес для массовой замены", _
                        Title:="Замена по списку", _
                        Default:=replaceRn.Address(True, True, xlA1, True), _
                        Type:=8)
        Err.Clear
        On Error GoTo 0
        ' Если пользователь отменил выделение - выйдем из макроса с предупреждением
        If Not inputRn Is Nothing Then
            Set replaceRn = inputRn
        Else
            MsgBox "Диапазон не выбран", vbCritical
            Exit Sub
        End If
    End With
    
    ' Для каждой пары заменяемых значений сделаем замену
    For Each rrow In replacementsRn.Rows
        ' По умолчанию - обрабытываем ячейку
        proceed = True
        ' Проверяем наличие слов из списка
        For Each wordRn In startingWordsToIgnoreRn
            word = wordRn.Value
            If Left(rrow.Cells(1, 1).Value, Len(word)) = word Then
                proceed = False
                Exit For
            End If
        Next wordRn
        
        ' Если нет слов из списка - начинаем замену.
        If proceed Then
            replaceRn.Replace What:=rrow.Cells(1, 1).Value, Replacement:=rrow.Cells(1, 2).Value
        End If
    Next rrow
    
    ' Выведем сообщение о завершении работы (можно убрать)
    MsgBox "Done!", vbInformation
End Sub
In GoTo we trust
 
tolstak
Спасибо огромное.
Вижу в Вашем примере отрабатывает,  переношу в свой - не работает и не понимаю почему.
Может быть дело в _ в исключениях?
Подскажите пжста чтоне так?
 
Пример
 
ageres1982, упс, кажется, малеленькая опечатка  :)
Должно быть
Код
    ' Для каждой пары заменяемых значений сделаем замену
    For Each rrow In replaceRn.Rows
        ' По умолчанию - обрабытываем ячейку
        proceed = True

вместо
Код
    ' Для каждой пары заменяемых значений сделаем замену
    For Each rrow In replacementsRn.Rows
        ' По умолчанию - обрабытываем ячейку
        proceed = True
In GoTo we trust
 
Спасибо :)
Исключения теперь обходит, а когда нужно сделать замену выдаёт 13 ошибку.
Добавил пример.
 
 
ageres1982, кажется, я совсем запутался в своем старом коде, прощу прощения... :-)
Код
Option Explicit
Option Compare Text

Sub XXXX()
...
Dim replaceRn As Range, inputRn As Range, replacementsRn As Range, startingWordsToIgnoreRn As Range, rrow As Range, proceed As String, wordRn As Range, word As String, where_to_replace_cell As Range
    ' Определяем диапазон со значениями для замен
    With ThisWorkbook.Sheets("Замена")
        ' Фразы для замены
        Set replacementsRn = Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp).Offset(0, 1))
        ' Если ячейка начинается на эти слова - не делаем замену
        Set startingWordsToIgnoreRn = Range(.Cells(2, 4), .Cells(.Rows.Count, 4).End(xlUp))
    End With
    
    With ThisWorkbook.Sheets("Поиск")
        ' Устанавливаем стартовый диапазон
        Set replaceRn = Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp))
        ' Выделяем стартовый диапазон
        replaceRn.Parent.Activate
        replaceRn.Select
        ' Выведем запрос на изменение диапазона
        On Error Resume Next
        Set inputRn = Application.InputBox( _
                        Prompt:="Адрес для массовой замены", _
                        Title:="Замена по списку", _
                        Default:=replaceRn.Address(True, True, xlA1, True), _
                        Type:=8)
        Err.Clear
        On Error GoTo 0
        ' Если пользователь отменил выделение - выйдем из макроса с предупреждением
        If Not inputRn Is Nothing Then
            Set replaceRn = inputRn
        Else
            MsgBox "Диапазон не выбран", vbCritical
            Exit Sub
        End If
    End With
    
    For Each where_to_replace_cell In replaceRn.Cells
    ' По умолчанию - обрабытываем ячейку
        proceed = True
        ' Проверяем наличие слов из списка
        For Each wordRn In startingWordsToIgnoreRn
            word = wordRn.Value
            If Left(where_to_replace_cell.Cells(1, 1).Value, Len(word)) = word Then
                proceed = False
                Exit For
            End If
        Next wordRn
        ' Если нет слов из списка - начинаем замену.
        If proceed Then
            ' Для каждой пары заменяемых значений сделаем замену
            For Each rrow In replacementsRn.Rows
                where_to_replace_cell.Replace What:=rrow.Cells(1, 1).Value, Replacement:=rrow.Cells(1, 2).Value
            Next rrow
        End If
    
    Next where_to_replace_cell
    ' Выведем сообщение о завершении работы (можно убрать)
    MsgBox "Done!", vbInformation
End Sub
Изменено: tolstak - 22.07.2020 13:38:15 (В очередной раз поправил формулу :-))
In GoTo we trust
 
Не работает..
Z_BW_AUTH_AO_YPLANT_3305 - должно остаться без изменения т.к есть в списке исклюения (тут не ок),
а для ZEAD_FI_03_02_D910 должен убраться хвостик _D910 (тут всё ок)
 
Спасибо огромное, теперь всё работает  :)  
 
Цитата
Nordheim написал:
Еще вариант:
Красиво. Я бы только доделал, чтобы срабатывало и в том случае, если есть несколько слов на замену в одной ячейке. Хотя сейчас это ТС, похоже, не требуется :)
Всё сложное - не нужно. Всё нужное - просто /М. Т. Калашников/
 
Подскажите пожалуйста, почему может не работать макрос. Суть в следующем: ячейки с "нет данных" (#Н/Д) заменить на пробел.
Код
Sub Макрос1()[
    Cells.Replace What:="#Н/Д", Replacement:="", LookAt:=xlPart, SearchOrder _
        :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
End Sub
 
Марина Александрова, возможно у Вас там формула выдает ошибку, а не значение #Н/Д.
В теории, можно написать такой макрос:
Код
    Dim errRn As Range
    ' Selection = Текущие выделенные ячейки
    For Each ccell In Selection
        If IsError(ccell) Then
            If errRn Is Nothing Then
                Set errRn = ccell
            Else
                Set errRn = Union(errRn, ccell)
            End If
        End If
    Next ccell
    If Not errRn Is Nothing Then
        'Значение для замены
        errRn.Value = " "
    End If
End Sub
In GoTo we trust
 
Спасибо за помощь
 
Цитата
написал:
tolstak
Огромное спасибо, очень сильно помогли упростить рутину
Один момент только когда пытаюсь  применить его в своем файле выдает ошибку на
Set replacementsRn = Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp).Offset(0, 1))
подскажите что с этим делать
Изменено: Михаил Накаряков - 18.11.2021 15:20:29
 
Цитата
написал:
Sub test()
'   ---------------------------------------------
   Dim dic As Object, i&, txt$
   Dim allrange As Range, rng As Range
'   ---------------------------------------------
   Application.ScreenUpdating = False
   Set dic = CreateObject("Scripting.Dictionary")
   Set allrange = Application.InputBox("Выберите диапазон", Type:=8)
   arr = Worksheets("ReplaceList").UsedRange.Value
   For i = 1 To UBound(arr)
       txt = arr(i, 1)
       dic.Item(txt) = arr(i, 2)
   Next i
   For Each rng In allrange
       txt = rng.Value
       If dic.exists(txt) Then rng.Value = dic.Item(txt)
   Next rng
   Application.ScreenUpdating = True
End Sub
Я люблю вас
Страницы: 1
Наверх