Поиск  Пользователи  Правила 
Закрыть
Логин:
Пароль:
Забыли свой пароль?
Регистрация
Войти
 
Страницы: 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 Авг 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
Страницы: 1
Читают тему (гостей: 1)
Наверх