Matching keywords with Product Description

Elfabb · May 24th 2016

Hi everyone,

I have a database on Excel that is basically a compilation of three information from different sectors of the economy: Product Description, Product Code and Supplier. My aim is to extract from that worksheet (to another one) the information regarding only the sector that I need. Unfortunately, there is no filter whatsoever and the only way for me to identify the products that I want is by the Product Description, that has some keywords associated with the sector that I'm interested. I created a list of keywords that the Product Description might have and also a macro to go through this list and match those Product's Descriptions that contain it. After it matches something, it creates an entry on the new list that I'm building (to have only the products that I need).

The code is the one that follows:

Code

Sub MacroName()
    Dim li_Line_1 As Integer
    Dim li_Line_2 As Integer
    Dim li_Line_3 As Integer
 
    li_Line_1 = 2
    li_Line_2 = 3
    li_Line_3 = 3
   
    Do While Worksheets("WksInput").Cells(li_Line_1, 3) <> Empty
        Do While Worksheets("WksOutput").Cells(li_Line_2, 6) <> Empty
            Worksheets("WksOutput").Range("C" & li_Line_3).Select
                ActiveCell.Formula = "=SEARCH('WksOutput'!F" & li_Line_2 & ", 'WksInput'!E" & li_Line_1 & ")"
                If IsNumeric(ActiveCell) = True Then
                ActiveCell.Formula = "=CELL(""contents"",'WksInput'!E" & li_Line_1 & ")"
                Worksheets("WksOutput").Range("B" & li_Line_3).Select
                ActiveCell.Formula = "=CELL(""contents"",'WksInput'!C" & li_Line_1 & ")"
                Worksheets("WksOutput").Range("D" & li_Line_3).Select
                ActiveCell.Formula = "=CELL(""contents"",'WksInput'!B" & li_Line_1 & ")"
                li_Line_3 = li_Line_3 + 1
                li_Line_1 = li_Line_1 + 1
                Else
                li_Line_2 = li_Line_2 + 1
                li_Line_3 = li_Line_3
                End If
        Loop
    li_Line_2 = 3
    li_Line_1 = li_Line_1 + 1
    Loop
End Sub

Display More

Where:

Line_1 = first line of the data base
Line_2 = first line of keywords' list
Line_3 = first line of the new list (with the products that I want)

WksInput = worksheet of the data base
WksOutput = worksheet of the new list

As you guys can see, it's an awful code (I have no experience at all at programming). It works, but it's a lot slow and it must have a simpler way of doing this. I used Do While because I'll be updating the database and the keywords' list regularly, so I thought it was a good idea for saving time on the future.

Could you guys help me? Any tips will be welcome. Also, I hope I've made myself clear. I can try detailing a bit more if needed.

Thanks a lot!!!

Fuzz-Head · May 24th 2016

Re: Matching keywords with Product Description

Not sure how big your sheet is so any chance you can attach a sample worksheet?

Elfabb · May 24th 2016

Re: Matching keywords with Product Description

Hi Fuzz-Head,

Thank you for the reply!! Please find attached the database with the new list I'm trying to create. I used the same specification as in the OP. Just for you to know, there are 23k+ entries and they are in portuguese, don't know if it's going to be of any problem to you. I hope you can work something out..

Again, thank you for the support!

forum.ozgrid.com/index.php?attachment/69223/

Fuzz-Head · May 24th 2016

Re: Matching keywords with Product Description

So lets see if I have this correct.. On your WksOutput sheet Column F starting on Row 3, you want to put some names of some keywords down that column.

You then want to search through WksInput Sheet and on any match's in either Column B or Column D return those results in the order of Columns B thru D on the WksOutput correct?

Elfabb · May 24th 2016

Re: Matching keywords with Product Description

Yes, that's correct! But I want to search the keywords only on Column D (Product Description), Column B is not needed. Also, I forgot to add a remove duplicates mechanism on the end of the macro, since I believe there'll be duplicates on the list if I input two different keywords that appear on the same Product Description..

Fuzz-Head · May 24th 2016

Re: Matching keywords with Product Description

Try this and see if this does what your looking for.

Code

Sub Elfabb()




Dim vData() As Variant, vFind() As Variant, vPaste() As Variant
Dim lData As Long, lFind As Long
Dim sTest As String




With Worksheets("WksInput")
    vData = .Range("B3").Resize(.Cells(Rows.Count, 2).End(xlUp).Row - 2, 3).Value
End With




With Worksheets("WksOutput")
    vFind = .Range("F3").Resize(.Cells(Rows.Count, 6).End(xlUp).Row - 2, 1).Value
        lFind = .Cells(Rows.Count, 2).End(xlUp).Row
            If lFind > 2 Then .Range("B3:D" & lFind).Delete shift:=xlUp
End With




ReDim vPaste(1 To 3, 1 To 1)




For lData = LBound(vData, 1) To UBound(vData, 1)
    sTest = UCase(vData(lData, 3))
    For lFind = LBound(vFind, 1) To UBound(vFind, 1)
        If InStr(1, sTest, UCase(vFind(lFind, 1)), vbTextCompare) > 0 Then
            vPaste(1, UBound(vPaste, 2)) = vData(lData, 2) 'Product Code
            vPaste(2, UBound(vPaste, 2)) = vData(lData, 3) 'Product Description
            vPaste(3, UBound(vPaste, 2)) = vData(lData, 1) 'Supplier
                ReDim Preserve vPaste(1 To 3, 1 To UBound(vPaste, 2) + 1)
        End If
    Next lFind
Next lData




With Worksheets("WksOutput")
    If UBound(vPaste, 2) > 1 Then
        .Range("B3").Resize(UBound(vPaste, 2), 3) = Application.WorksheetFunction.Transpose(vPaste)
            lFind = .Cells(Rows.Count, 3).End(xlUp).Row
                If lFind > 3 Then .Range("B3").Resize(lFind, 3).RemoveDuplicates Columns:=Array(1, 2, 3), Header:=xlNo
    End If
End With


End Sub

Display More

Elfabb · May 24th 2016

Re: Matching keywords with Product Description

That's exactly it, Fuzz-Head!!! Thank you so much for your help!!!

It's returning some type of error when I have just one keyword on the list, but since that's not going to be the case, that's fine. Also, I'll try to understand your code better for me to change it in case it's needed.

But again, thank you very much! I'll owe you one

Bests,

Fuzz-Head · May 24th 2016

Re: Matching keywords with Product Description

Sorry bout that, Here is the code modified for single word lookup.

Keep in mind, that partial match's are found which I think is what you wanted. So only typing in a few letters for a word for a match will find more results

Code

Sub Elfabb()




Dim vData() As Variant, vFind() As Variant, vPaste() As Variant
Dim lData As Long, lFind As Long
Dim sTest As String




With Worksheets("WksInput")
    vData = .Range("B3").Resize(.Cells(Rows.Count, 2).End(xlUp).Row - 2, 3).Value
End With




With Worksheets("WksOutput")
    lFind = .Cells(Rows.Count, 6).End(xlUp).Row - 2
        If lFind > 1 Then
            vFind = .Range("F3").Resize(.Cells(Rows.Count, 6).End(xlUp).Row - 2, 1).Value
        Else
            ReDim vFind(1 To 1, 1 To 1)
                vFind(1, 1) = .Range("F3").Value
        End If
        lFind = .Cells(Rows.Count, 2).End(xlUp).Row
            If lFind > 2 Then .Range("B3:D" & lFind).Delete shift:=xlUp
End With




ReDim vPaste(1 To 3, 1 To 1)




For lData = LBound(vData, 1) To UBound(vData, 1)
    sTest = UCase(vData(lData, 3))
    For lFind = LBound(vFind, 1) To UBound(vFind, 1)
        If InStr(1, sTest, UCase(vFind(lFind, 1)), vbTextCompare) > 0 Then
            vPaste(1, UBound(vPaste, 2)) = vData(lData, 2) 'Product Code
            vPaste(2, UBound(vPaste, 2)) = vData(lData, 3) 'Product Description
            vPaste(3, UBound(vPaste, 2)) = vData(lData, 1) 'Supplier
                ReDim Preserve vPaste(1 To 3, 1 To UBound(vPaste, 2) + 1)
        End If
    Next lFind
Next lData




With Worksheets("WksOutput")
    If UBound(vPaste, 2) > 1 Then
        .Range("B3").Resize(UBound(vPaste, 2), 3) = Application.WorksheetFunction.Transpose(vPaste)
            lFind = .Cells(Rows.Count, 3).End(xlUp).Row
                If lFind > 3 Then .Range("B3").Resize(lFind, 3).RemoveDuplicates Columns:=Array(1, 2, 3), Header:=xlNo
    End If
End With




End Sub

Display More

Elfabb · May 24th 2016

Re: Matching keywords with Product Description

Oh, thank you for the new code! And yes, it's a partial match that I wanted

Matching keywords with Product Description

Participate now!

Share