Question

您好，在此先感谢您的协助。我有一个工作表，其中有两个选项卡名为DATA PULL和LIST。 LIST选项卡在A列中包含关键字列表（250个单词）。我需要在DATA PULL选项卡的P和Q列中搜索这些关键字，并将所有匹配项返回到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

您的代码的一些提示：使用

    On error Resume Next

像您正在使用的那样是不好的做法，并且可能导致麻烦。因此，您可能会遇到其他错误，这些错误不会出现，这将阻止您调试它们并发现问题。我建议仅在有问题的行之前使用它，然后再使用

    On Error goto 0

恢复显示并查找其他可能的错误。

一种完全避免必须使用“ On Error Resume Next”的方法是使用“ Like”运算符。如果您使用

    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， “ A”），后跟任意种类或数量的字符。就像“搜索” =）一样！

进行此更改还迫使我适应您在代码中以“;”开头的方式，但这也是一种更好的方式：

    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”，可以帮助您找到它！

我只是希望我不要对变量和列表感到困惑，但是我认为现在您可以对自己的工作有所了解。希望对您有所帮助。

Answer 2

我认为您可以尝试以下方法：

编辑版本：

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

从列表中搜索列中的关键字，并将所有匹配项返回到其他列

2 个答案: