Поиск столбцов по ключевым словам из списка и возврат любых совпадений в другой столбец

Question

Здравствуйте и спасибо заранее за любую помощь. У меня есть рабочий лист с двумя вкладками под названием DATA PULL и LIST. Вкладка LIST содержит список ключевых слов (250 слов) в столбце A. Мне нужно найти эти ключевые слова в столбцах P и Q на вкладке DATA PULL и вернуть все совпадения в столбец I (данные находятся в таблице). Столбцы P и Q содержат несколько слов или предложений.

Код ниже делает то, что мне нужно, но список ключевых слов находится на том же листе. Этот код также по какой-то причине удаляет буквы из заголовков таблицы.

Sub GetWords()

Dim wrdLRow As Integer
Dim wrdLp As Integer
Dim CommentLrow As Integer
Dim CommentLp As Integer
Dim fndWord As Integer
Dim Sht As Worksheet

On Error Resume Next 'Suppress Errors... for when we don't find a match

'Define worksheet that has data on it....
Set Sht = Sheets("DATA PULL")

'Get last row for words based on column A
wrdLRow = Sht.Cells(Rows.Count, "A").End(xlUp).Row

'Get last row for comments based on column C
CommentLrow = Sht.Cells(Rows.Count, "P").End(xlUp).Row

'Loop through lists and find matches....
For CommentLp = 2 To CommentLrow
    For wrdLp = 2 To wrdLRow
       'Look for word...
       fndWord = Application.WorksheetFunction.Search(Sht.Cells(wrdLp, "A"), Sht.Cells(CommentLp, "P"))
       'If we found the word....then
       If fndWord > 0 Then
           Sht.Cells(CommentLp, "I") = Sht.Cells(CommentLp, "I") & "; " & Sht.Cells(wrdLp, "A")
           fndWord = 0 'Reset Variable for next loop
       End If
    Next wrdLp
    Sht.Cells(CommentLp, "I") = Mid(Sht.Cells(CommentLp, "I"), 3, Len(Sht.Cells(CommentLp, "I")) - 2)

Next CommentLp


End Sub

Любая помощь очень ценится.

LIST

DATAPULL

Answer 1

Я думаю, вы могли бы попробовать это:

РЕДАКТИРОВАННАЯ ВЕРСИЯ:

Option Explicit

Sub test()

    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim LRA As Long, i As Long, LRP As Long, LRQ As Long, LRI As Long
    Dim SearchingValue As String
    Dim rng As Range, cell As Range

    With ThisWorkbook

        Set ws1 = .Worksheets("DATA PULL")
        Set ws2 = .Worksheets("LIST")

        With ws1

            LRP = .Cells(.Rows.Count, "P").End(xlUp).Row
            LRQ = .Cells(.Rows.Count, "Q").End(xlUp).Row

            Set rng = .Range("P1:P" & LRP, "Q1:Q" & LRQ)

        End With

        With ws2

            LRA = .Cells(.Rows.Count, "A").End(xlUp).Row

            For i = 1 To LRA

                SearchingValue = .Range("A" & i).Value

                For Each cell In rng

                    If InStr(1, cell.Value, SearchingValue) > 0 Then
                        With ws1
                            LRI = .Cells(.Rows.Count, "I").End(xlUp).Row
                            .Range("I" & LRI + 1).Value = "Value " & """" & .Range("A" & i).Value & """" & " appears in sheet DATA PULL, " & "column " & cell.Column & ", row " & cell.Row & "."
                        Exit For
                        End With
                    End If

                Next cell

            Next i

        End With

    End With

End Sub

Answer 2

Несколько советов для вашего кода: Использование

    On error Resume Next

, как вы используете, является плохой практикой и может привести к проблемам.У вас могут быть другие ошибки, которые не будут отображаться из-за этого, и это предотвратит их отладку и обнаружение проблемы.Я бы рекомендовал использовать его только перед проблемной строкой, а после этого использовать

    On Error goto 0

для возобновления отображения и поиска других возможных ошибок.

Способ полного отказа от использования "On Error"Resume Next »использует оператор« Мне нравится ».Если вы используете

    If Sht.Cells(CommentLp, "P") Like "*" & Sht.Cells(wrdLp, "A") & "*" Then
        Sht.Cells(CommentLp, "I") = Sht.Cells(CommentLp, "I") & "; " & Sht.Cells(wrdLp, "A")
    End If

Вы можете сделать то же самое, не беспокоясь об ошибках.По сути, «Мне нравится» выполняет поиск, чтобы увидеть, похож ли текст на другой.Два «*» означают любой вид и количество символов, поэтому все вместе означает, что Sht.Cells (CommentLp, «P») должны быть похожи: любой тип и количество символов, за которыми следует значение Sht.Cells (wrdLp,«А»), за которым следует любой вид или количество символов.Точно так же, как «Поиск» =)!

Внесение этого изменения также вынудило меня адаптировать способ работы со стартовым символом «;» в вашем коде, но также и к лучшему способу:

    Dim wrdLRow As Integer
    Dim wrdLp As Integer
    Dim CommentLrow As Integer
    Dim CommentLp As Integer
    Dim fndWord As Integer
    Dim DataSht As Worksheet
    Dim ListSht as Worksheet

    'Define the worksheets
    Set DataSht = Sheets("DATA PULL")
    Set ListSht = Sheets("LIST")


    'Get last row for words based on column A
    wrdLRow = ListSht.Cells(Rows.Count, "A").End(xlUp).Row

    'Get last row for comments based on column C
    CommentLrow = DataSht.Cells(Rows.Count, "P").End(xlUp).Row
    For CommentLp = 2 To CommentLrow
      For wrdLp = 2 To wrdLRow
        If LCASE(DataSht.Cells(CommentLp, "P")) Like "*" & LCASE(ListSht.Cells(wrdLp, "A")) & "*" Then
          If DataSht.Cells(CommentLp, "I") <> "" Then
            DataSht.Cells(CommentLp, "I") = DataSht.Cells(CommentLp, "I") & "; " & ListSht.Cells(wrdLp, "A")
          Else
            DataSht.Cells(CommentLp, "I") = ListSht.Cells(wrdLp, "A")
          End If
        ElseIf LCASE(Sht.Cells(CommentLp, "Q")) Like "*" & LCASE(Sht.Cells(wrdLp, "A")) & "*" Then
          If NewSht.Cells(writeRow, "A") <> "" Then
            NewSht.Cells(writeRow, "A") = NewSht.Cells(writeRow, "A") & "; " & Sht.Cells(wrdLp, "A")
          Else
            NewSht.Cells(writeRow, "A") = Sht.Cells(wrdLp, "A")
          End If
        End If
      Next wrdLp
    Next CommentLp

Этот код работает для меня без проблем, но ваш тоже.Я предполагаю, что вы не передали весь свой код, также потому что вы упомянули два столбца и написали код только для одного.Я думаю, что проблема может быть в той части, которой вы не поделились, и, возможно, эта модификация, которую я написал, без «On Error Resume Next», поможет вам найти ее!

Я просто надеялся, что не сделалзапутаться с переменными и списком, но я думаю, теперь вы можете иметь хорошее представление о том, что я делаю.Надеюсь, это поможет.