markusvirus
New Member
- Joined
- Dec 15, 2015
- Messages
- 1
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:
[/COLOR][/CODE]
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:
Code:
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]
Last edited: