excel vba查找关键字列表，如果存在查找值，然后编辑另一个单元格的值

我有一个列表，每个人吃一种特定的蔬菜。 例如，约翰，史密斯吃土豆和番茄。 比尔，彼得吃胡萝卜，洋葱。 我已经创build了一个列表，看起来像这样的关键字

现在，我收到一个数据摘录，其中有一个名称列表以及他们吃的食物的自由文本描述。 这是我得到的

不幸的是，我得到了一些我不想要的名字，比如John，Smith（Primary Customer），我希望excel可以添加他们吃的蔬菜，因为它是写在描述中的。 例如，John，Smith（主要客户）的描述是：“他有炸薯条和楔子”，并且由于描述中包含的关键字列在我的初始表中，对于同一个人，他的名字将从John，Smith（主要客户）转交给John，Smith-Potato（主要客户）。

我想要excel来检查名称是否存在于第一个表中，然后查看描述来find任何关键字。 这将确保如果手头的名字不包含在我的清单中，那么Excel不会花时间寻找关键字。 另外，如果没有find关键字，那么不要编辑名称。

这是我期望得到的

这里是代码尝试如此之多…我不断收到一个错误，我没有达到的目的来validation这个代码，以检查它是否给了我我正在寻找的结果..任何帮助，非常感谢。

Option Explicit Sub homework() Dim ws1 As Worksheet, ws2 As Worksheet, keywords() As String, lastRow As Integer, lastRow2 As Integer, c As Variant, x As Integer, y As Integer, k As Variant, cel As Range, descript As Range Dim SrchRng As Range Dim SrchStr As Variant Set ws1 = Worksheets("Sheet2") 'the sheet that contains keywords which is the sheet i will make Set ws2 = Worksheets("Sheet1") 'the sheet that contains description of food lastRow = ws1.Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, searchdirection:=xlPrevious).Row lastRow2 = ws2.Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, searchdirection:=xlPrevious).Row Set SrchRng = Worksheets("Sheet2").Range("A1:A1000") Set descript = ws2.Range("C2:C" & lastRow2) For x = 2 To lastRow ' this is to the last row in the database i will create keywords = Split(ws1.Cells(x, 3), ",") For Each k In keywords For Each cel In descript For y = 2 To lastRow2 Do SrchStr = Left(ws2.Cells(y, 2), InStr(ws2.Cells(y, 2), " (") - 1) Set c = SrchRng.Find(SrchStr, LookIn:=xlValues) If Not SrchRng.Find(SrchStr, LookIn:=xlValues) Is Nothing And InStr(ws2.Cells(y, 3), k) <> 0 Then ws2.Cells(y, 2).Value = ws1.Cells(x, 1).Value & "-" & ws1.Cells(x, 2).Value SrchStr = Nothing Exit Do End If Loop While Not c Is Nothing Next y Next cel Next k Next x End Sub 

Answer 1

我认为按照下面的说法是可行的，改变范围以满足您的需求，但是它会根据列表1st检查客人名称，然后将关键字分配给一个数组并检查它们。

 Sub example1() Dim WS1 As Worksheet, WS2 As Worksheet Dim GuestName() As Variant, Keywords As Variant Dim GNi As Integer, Ri As Integer, KWi As Integer Set WS1 = Worksheets("Sheet2") Set WS2 = Worksheets("Sheet1") With WS1 GuestName = .Range("A2:A" & .Cells.SpecialCells(xlCellTypeLastCell).Row) End With With WS2 For Ri = 2 To .Cells.SpecialCells(xlCellTypeLastCell).Row 'starting at the 2nd row to the last row with data on the sheet For GNi = 1 To UBound(GuestName) If InStr(1, .Range("B" & Ri), GuestName(GNi, 1)) > 0 Then 'searches for the guestname to match against Keywords = WS1.Range("C" & GNi + 1) 'assigns the keywords matching the guestname Keywords = Split(Keywords, ",") For KWi = 0 To UBound(Keywords) If InStr(1, .Range("C" & Ri), Keywords(KWi)) > 0 Then 'found keyword End If Next End If Next Next End With End Sub