How to Assign specific value to a clumn based on text in another column using VBA?

[divyasn31]

Hi, Could someone help me with the VBA code to assign a specific value to a column ("Category") based on the value in another column ("Item")?
For example:
Sheet Name: Source Data
Column Headers: Product ID (Col. A)
Items (Col. B)
Store (Col. C)
Category (Col. D)

The "category" is assigned based on the occurrence of the first word in "Items". Below are the criteria:

Item​	Category ​
Apple	Fruit
Mangoes	Fruit
Orange	Fruit
Carrot	Vegetable
Eggplant	Vegetable
Cola	Drink
Smoothie	Drink
Sprite	Drink

Now, if cell B2 (Item)= "Apple, Mangoes, and Cola", then I want cell D2 (Category)="Fruit". Since Apple is the first word in B2 that matches the Criteria above.
if cell B3= "Cola, Apples, and Cakes", then I want D2= "Drink". Since Cola is the first word in B3 and the category is Drink based on the above table.
if Cell B4="Cakes, Lemons, Apple, Cola, and Smoothie", I want D2= "Fruit". In this case, we don't have cakes or lemons in the above table, the next word is Apple which we already have on our table. Therefore I want D2 as Fruit.

 

[Peter_SSs]

I would consider O'Connor as one word and Coca-Cola also as one word.

The problem with that in relation to my sample sentence is that there is no reasonably simple logic that we can program (that I can think of) to tell Excel to treat the first apostrophe as part of the word it is in but not treat the second one the same way.

Basically based on my requirement a new word is separated by- space, ",", ".", "/".

OK, based on that give this a try

Sub LookupCategory_v2()
  Dim d As Object
  Dim a As Variant, b As Variant, itm As Variant
  Dim i As Long, j As Long
  Dim s As String
  
  Const Punctuation As String = ",./" '<- Add more here if required
  
  Set d = CreateObject("Scripting.Dictionary")
  d.CompareMode = 1
  With Sheets("Item Categorisation List")
    a = .Range("A2", .Range("B" & Rows.Count).End(xlUp)).Value
  End With
  For i = 1 To UBound(a)
    d(a(i, 1)) = a(i, 2)
  Next i
  With Sheets("Source Data")
    a = .Range("B2", .Range("B" & Rows.Count).End(xlUp)).Value
    ReDim b(1 To UBound(a), 1 To 1)
    For i = 1 To UBound(a)
      s = a(i, 1)
      For j = 1 To Len(Punctuation)
        s = Replace(s, Mid(Punctuation, j, 1), " ")
      Next j
      For Each itm In Split(Application.Trim(s))
        If d.exists(itm) Then
          b(i, 1) = d(itm)
          Exit For
        End If
      Next itm
    Next i
    .Range("D2").Resize(UBound(b)).Value = b
  End With
End Sub

Here are my sample data and results

divyasn31.xlsm
	A	B
1	Item	Category
2	Apple	Fruit
3	Mangoes	Fruit
4	Orange	Fruit
5	Carrot	Vegetable
6	Eggplant	Vegetable
7	Cola	Drink
8	Smoothie	Drink
9	Sprite	Drink
10	O'Connor	Person
11	Coca-Cola	Drink
Item Categorisation List

divyasn31.xlsm
	B		D
1	Items		Category
2	Apple, Mangoes, and Cola		Fruit
3	Cola, Apples, and Cakes		Drink
4	Cakes, Eggplant, Apple, Cola, and Smoothie		Vegetable
5	Eggplant, Apple, Cakes		Vegetable
6	Eggplant is in the list		Vegetable
7	Ann O'Connor likes Coca-Cola's flavour - mostly		Person
8	Ann likes Coca-Cola's flavour but not apple		Fruit
9	Ann likes Coca-Cola but not apple		Drink
Source Data

 

[divyasn31]

Thats awesome. Thanks a lot Peter.

 

[Peter_SSs]

You're welcome. Thanks for the follow-up.