Data Entry Using Keywords

[markusvirus]

Hi Experts,

Can someone walk me through attaching/sharing my sample file.
Ok, So I have column K that contains a long text description, and I have thousands of cells like this.
So what I'm trying to do is to categorize each cell by main keywords.

B.W it should be possible to have a few keywords for each description. Is it possible for one keyword category to supercede the others, what are my options?
-----

I have set of keywords under "Categories" Tab, I've already started the codes, it is working, but shows multiple categories when multiple keywords are found under column K.

PS:
I am also planning to write a code for column M to fill sub-categories based on column K keywords too.

Help please.




Module 1:

Option Explicit


Sub Categorize()


'  "Workfile-Current Month" is Sheet3        '
'  "Categories" is Sheet10  '


Dim rCategories As Range, rWhatCat As Range, rKeyWords As Range, rWhereLook As Range, rMatches As Range, rCurVal As Range
Dim i As Long, j As Long
Dim bFound As Boolean


Set rCategories = Sheet10.Cells(2, 1).Resize(1, Sheet10.Cells(2, Columns.Count).End(xlToLeft).Column)
Set rWhereLook = Sheet3.Range("K:K")


'Clear Main Column L'
Sheet3.Range("L2:L" & Sheet3.UsedRange.Rows.Count).ClearContents


 For Each rWhatCat In rCategories
    If rWhatCat.Offset(1, 0).Value = "" Then GoTo NEXT_CAT
        
    'Find matches for keyword'
    Set rKeyWords = rWhatCat.Offset(1, 0).Resize(Sheet10.Cells(Rows.Count, rWhatCat.Column).End(xlUp).Row - rWhatCat.Row, 1)
    For Each rCurVal In rKeyWords
        Call FindAll_TEXT(rWhereLook, rMatches, rCurVal.Value, bFound)
NEXT_KEYWORD:
    Next rCurVal
    'Label the "Workfile-Current Month" column L with the category for all matches.'
    If rMatches Is Nothing Then GoTo NEXT_CAT
    For Each rCurVal In rMatches
        If Sheet3.Cells(rCurVal.Row, "L") = "" Then
            Sheet3.Cells(rCurVal.Row, "L") = rWhatCat.Value
        Else
            Sheet3.Cells(rCurVal.Row, "L") = Sheet3.Cells(rCurVal.Row, "L") & ", " & rWhatCat.Value
        End If
    Next rCurVal
    Set rMatches = Nothing
NEXT_CAT:
 Set rMatches = Nothing
 
 Next rWhatCat
 End Sub




Sub FindAll_TEXT(ByRef fullRange As Range, ByRef matchRange As Range, findValue As String, ByRef findResults As Boolean)
'Markus'
Dim currK As Range, firstK As Range
Dim collectionK As Range


findResults = False
If Not matchRange Is Nothing Then Set collectionK = matchRange
Set currK = fullRange.Find(What:=findValue, LookIn:=xlFormulas, LookAt:=xlPart, MatchCase:=False)


If Not currK Is Nothing Then
    findResults = True
End If


If findResults Then


    Set firstK = currK
        
    Do
    If collectionK Is Nothing Then
        Set collectionK = currK
    Else
       Set collectionK = Union(currK, collectionK)
    End If
    Set currK = fullRange.FindNext(currK)
    Loop While Not currK.Address = firstK.Address


    Set matchRange = collectionK
End If


End Sub
[COLOR=#333333]

[/COLOR][/CODE]

 

[Mohammad Basem]

Hi markusvirus,

To share a file, Upload it to a cloud drive (Dropbox, Google Drive, OneDrive…) and provide the link in your post.

You can also post sample data using Excel to Html converters, like Excel Jeanie Html, or you may select the table in Excel, copy and paste it in the reply box.

Regarding the keywords. Normally, a subject can have more than one keyword and when searching for certain keyword you will get the subject.

In your case, it is correct that you get the same category for different keywords identifying this category, but you need to think of how to eliminate the duplications to suit your goal.