Заполнить столбец вводом на основе частичного совпадения из другого столбца

Question

У меня есть лист 1, в котором столбец содержит список доменов, например www.nonsence.bg/sport, www.example.cn/streets, www.news.gr/sports

Я хотел бы заполнить поле Country в столбце A на основе таблицы «KEY», которая хранится на листе 4, где столбец A = домен (например, «.gr /», «.bg /», «.cn» / ") и столбец B = страна (Греция, Китай, Болгария).

Я использую следующий код для поиска / замены, но с частичным соответствием он кажется немного сложнее:

Sub substitute()

Dim Sh1 As Worksheet
Dim Sh2 As Worksheet
Dim FndList, x&


Set Sh1 = Sheets(1)
Set Sh2 = Sheets(3)
FndList = Sh2.Cells(1, 1).CurrentRegion
For x = 1 To UBound(FndList)
    Sh1.Cells.Replace What:=FndList(x, 1), replacement:=FndList(x, 2), LookAt:=xlPart
Next
End Sub

Answer 1

Тем более, что ваши записи в таблице KEY имеют форму xx/, это довольно просто сделать с помощью формулы:

Я превратил ключевую таблицу в «настоящую» таблицу и я использую структурированные ссылки, но вы можете изменить это на обычные ссылки, если предпочитаете

B2: =INDEX(tblKEY[Country], MATCH(TRUE,ISNUMBER(MATCH("*" & tblKEY[Domain]&"*",A2,0)),0))

KEY table
(с именем tblKEY)

Results

введите описание изображения здесь

Вы можете сделать то же самое с VBA и методом Range.Find, если вам необходимо использовать VBA по какой-либо другой причине:

Option Explicit
Sub Country()
    Dim wsSrc As Worksheet, LO As ListObject
    Dim rSrc As Range, C As Range, CC As Range
    
'Change these to represent your actual locations
Set wsSrc = ThisWorkbook.Worksheets("sheet5")
Set rSrc = wsSrc.Cells(1, 1).CurrentRegion.Offset(rowoffset:=1)
Set LO = wsSrc.ListObjects("tblKEY")

Application.ScreenUpdating = False
rSrc.Columns(2).ClearContents
For Each CC In LO.DataBodyRange.Columns(1).Cells
    With rSrc.Columns(1)
        Set C = .Find(what:=CC.Value, LookIn:=xlValues, lookat:=xlPart, MatchCase:=False)
        If Not C Is Nothing Then
            C.Offset(0, 1) = CC.Offset(0, 1)
        End If
    End With
Next CC
End Sub

Answer 2

Если я правильно понял, что вы хотите, это должно сработать

Sub UpdateCountries()
    Dim vCountriesList As Variant
    Dim i As Long
    Dim j As Long
    Dim lLastRow As Long
    
    With ThisWorkbook.Sheets("Sheet4")
        vCountriesList = .Range(.Cells(2, "A"), .Cells(Rows.count, "B").End(xlUp)).Value
    End With
    
    With ThisWorkbook.Sheets("Sheet1")
        lLastRow = .Cells(Rows.count, "H").End(xlUp).Row
        For i = 2 To lLastRow
            For j = 1 To UBound(vCountriesList, 1)
                If InStr(1, .Cells(i, "H"), vCountriesList(j, 1), vbTextCompare) > 0 Then
                    If .Cells(i, "A").Value <> vCountriesList(j, 2) Then
                        .Cells(i, "A").Value = vCountriesList(j, 2)
                    End If
                    Exit For
                End If
            Next j
        Next i
    End With
End Sub