Поиск / замена на основе списка в другом листе (та же рабочая книга)

Question

В моей книге есть лист со списком пар аббревиатур / полных строк (например, "GG" / "Gotta Go").Имя листа - «Определения», а столбцы - C и D. В будущем список может быть обновлен, добавив больше пар.

Затем в той же книге будет другой лист, содержащий 5 столбцов (от P доТ).Эти столбцы содержат сокращения в случайных строках, некоторые строки пусты или содержат разные данные.Название листа - «Цель».Был бы способ соединить код VBA, который прошел бы по списку пар и заменил бы сокращения, найденные в полях P на T, соответствующими полными строками?Некоторые целевые столбцы могут содержать пустые ячейки, поэтому, если бы у кода была возможность проверять и пропускать пустые ячейки, это было бы очень хорошо.

РЕДАКТИРОВАТЬ: добавление кода, любезно собранного Mumps в Ozgrid.

Sub ReplaceAbbrev() 

Application.ScreenUpdating = False
Dim LastRow1 As Long
Dim LastRow2 As Long
Dim foundDef As Range
Dim def As Range
Dim sAddr As String

LastRow1 = Sheets("Definitions").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
LastRow2 = Sheets("Target").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

For Each def In Sheets("Definitions").Range("C2:C" & LastRow1)
    Set foundDef = Sheets("Target").Range("P2:T" & LastRow2).Find(def, LookIn:=xlValues, lookat:=xlWhole)
    If Not foundDef Is Nothing Then 'if found
        sAddr = foundDef.Address
        Do
            Set foundDef = Sheets("Target").Range("P:T").FindNext(foundDef)
            Sheets("Target").Range(foundDef.Address).Value = Replace(Sheets("Target").Range(foundDef.Address).Value, def, def.Offset(0, 1))

        Loop While Not foundDef Is Nothing
        sAddr = ""
    End If
Next def

Set foundDef = Nothing
Application.ScreenUpdating = True

End Sub

Answer 1

Или следующее, основанное на сопоставлении всего содержимого ячеек (вы можете изменить на xlPart для частичных совпадений.) Это эффективный цикл, поскольку вы зацикливаете только определения, поэтому столько раз, сколько требуется.Замена работает только над заполненными строками целевых столбцов.Замена выполняется за один раз.

Public Sub ReplaceAbbrev()

    Application.ScreenUpdating = False
    Dim LastRow1 As Long
    Dim LastRow2 As Long
    Dim targetRange As Range
    Dim def As Range

    With Worksheets("Definitions")
        LastRow1 = .Cells(.Rows.Count, "C").End(xlUp).Row
    End With

    With Worksheets("Target")
        LastRow2 = .Cells(.Rows.Count, "P").End(xlUp).Row
    End With

    Set targetRange = Worksheets("Target").Range("P2:T" & LastRow2)

    For Each def In Worksheets("Definitions").Range("C2:C" & LastRow1)

        targetRange.Cells.Replace What:=def, Replacement:=def.Offset(0, 1), LookAt:=xlWhole

    Next def

    Application.ScreenUpdating = True

End Sub

Answer 2

Примерно так:

 Dim TargetRange As range, DefPairsRange As range
Set TargetRange = Worksheets("Target").[P:T]   'Set target range

Set DefPairsRange = Worksheets("Definitions").[C1:D10] 'Set definition Range
Set DefPairsRange = range(DefPairsRange, DefPairsRange.End(xlDown))  'extend the range if need it
For R = 1 To DefPairsRange.Rows.count 'iterate through definitions and replace targets
Call TargetRange.Replace(DefPairsRange(R, 0).value, DefPairsRange(R, 1).value)
Next