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

divyasn31

New Member
Joined
Aug 15, 2021
Messages
7
Office Version
  1. 365
  2. 2019
Platform
  1. Windows
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
AppleFruit
MangoesFruit
OrangeFruit
CarrotVegetable
EggplantVegetable
ColaDrink
SmoothieDrink
SpriteDrink

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.
 
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

VBA Code:
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
AB
1ItemCategory
2AppleFruit
3MangoesFruit
4OrangeFruit
5CarrotVegetable
6EggplantVegetable
7ColaDrink
8SmoothieDrink
9SpriteDrink
10O'ConnorPerson
11Coca-ColaDrink
Item Categorisation List


divyasn31.xlsm
BD
1ItemsCategory
2Apple, Mangoes, and ColaFruit
3Cola, Apples, and CakesDrink
4Cakes, Eggplant, Apple, Cola, and SmoothieVegetable
5Eggplant, Apple, CakesVegetable
6Eggplant is in the listVegetable
7Ann O'Connor likes Coca-Cola's flavour - mostlyPerson
8Ann likes Coca-Cola's flavour but not appleFruit
9Ann likes Coca-Cola but not appleDrink
Source Data
 
Upvote 0
Solution

Excel Facts

Copy PDF to Excel
Select data in PDF. Paste to Microsoft Word. Copy from Word and paste to Excel.

Forum statistics

Threads
1,223,903
Messages
6,175,284
Members
452,630
Latest member
OdubiYouth

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top