Находим слово в ячейке из списка ключевых слов и в соседних колонках ставим соответствующее значение по mapping'у

Подскажите, что не так с кодом ниже?

На "source" бегу вниз до конца и сравниваю InStr с ключевыми словами с "map" (также бегаю по всему списку ключевых слов).

Ожидаю: в столбцах "P" и "Q" проставить соответствующую информацию.

Но результат разочаровал: только в колонке "P" проставил, что типа не нашёл соответствий с ключевыми словами что ли?

Подскажите плиз где что забыл в коде?

Код прикладываю. Тестовый файл тоже могу приложить/выслать

Sub FindKeyWord()

    'На закладке "source" пытаемся найти ключевое слово (с закладки "map") в столбце "А" и в колонках "P" и "Q" проставить соответствующую информацию
    Dim SourceData As Worksheet: Set SourceData = ThisWorkbook.Sheets("source") 'Change the name of the sheet
    Dim Mapping As Worksheet: Set Mapping = ThisWorkbook.Sheets("map") 'Change the name of the sheet
    
    Dim SourceDataLstr As Long, MappingLstr As Long
    Dim i As Long, j As Long
    Dim RawDataKey As String, MappingKey As String
    
    SourceDataLstr = SourceData.Range("A" & Rows.Count).End(xlUp).Row 'Find the lastrow in the Source Data Sheet
    MappingLstr = Mapping.Range("A" & Rows.Count).End(xlUp).Row 'Find the lastrow in the Mapping Sheet
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    With SourceData
        For i = 5 To SourceDataLstr
            'RawDataKey = InStr(1, .Cells(i, 1).Value, "", vbTextCompare)
            For j = 2 To MappingLstr
                MappingKey = Mapping.Cells(j, 4).Value
                RawDataKey = InStr(1, SourceData.Cells(i, 1).Value, Mapping.Cells(j, 4).Value, vbTextCompare)
                    If RawDataKey <> 0 Then
                        SourceData.Cells(i, 16).Value = Mapping.Cells(j, 2).Value And SourceData.Cells(i, 17).Value = Mapping.Cells(j, 1).Value
                        Exit For
                    End If
            Next j
        Next i
    End With
    
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    
End Sub

Ответы (0 шт):