Excel/Categorization Macro(formula) based on strin

Question

Now I spent a few days searching up and down and need to find a solution.

I saw two threads but both are not what I am looking for exactly and I admit, being not too good in VBA, I cant make heads or tales.

What I have: I have 4300 lines of Bank statements. There are multiple columns but 1 is of importance - Description. This description might contain a lot of things, but usually there is 1 key word that is crucial. Roughly 96% can be automated and 3-4% just written manually every now and then.

What I want:

A VBA Macro that will read the column description, will match a keyword there from a list of many such in Sheet2, column "keywords" and then write in Column Category (sheet1) the assigned Categorizaion taken from Column Category on Sheet2.

What I have done so far:

the only thing I found to be working for me, and be able to actually reproduce is using a formula:

=IF(ISNUMBER(SEARCH("KEYWORD",[Description])),"OUTPUT","")

The above formula was repeated multiple times but this slows and lags everything. Besides being unmanagable.

Its working but I need something better. So -> enter Macros. and here I am lost.

I found that the answer of @JohnBustos is very good here: How to group excel items based on custom rules? but not working for me really.

I found the answer of Tomk Dallimore to be what I need or want: Categorizing bank transactions in Excel

but I cant make heads or tales how to get there??? He is very detailed but I am getting lost on the complexity which mind you is great.

Can you please help me?

I am attaching a very simple example of what I am talking.

http://1drv.ms/1Putpy5

Note#1 I founnd a new formula that I incorporated. '=IFERROR(LOOKUP(10^10,SEARCH(" "&KeywordTable[In-keyword]&" "," "&H29& " "),KeywordTable[Out-keyword ]),"")

But this is also troubling the CPU as it calculates each time a cell is moved. I imagine it will throw exception if I add 560 new rows or better yet move the table with 1 poisition. Temporary solution but need something more sophisticated.

*****possibly a terrible idea**** To speed up the macro, such macro as the one you provided in your answer, is it possible to make it work like the automatic date filler macro: Private Sub Worksheet_Change(ByVal Target As Excel.Range)

With Target
            If .Count > 1 Then Exit Sub
            If Not Intersect(Range("B2:B100"), .Cells) Is Nothing Then
                Application.EnableEvents = False
                If IsEmpty(.Value) Then
                    .Offset(0, 3).ClearContents
                Else
                    With .Offset(0, 3)
                        .NumberFormat = "dd mmm yyyy hh:mm:ss"
                        .Value = Now
                    End With
                End If
                Application.EnableEvents = True
            End If
        End With
    End Sub

Of course, I realize I am asking for something strange but if this can happen it will be rather fast and extremely helpful for optimzing the speed at which the macro is executed for large amounts of data. Now, I have 4500 rows to calculate. Within 2 months, this amount will double.

Answer 1

Based on your excel file this code works: 10'000 rows done in 3 secondes with this code.

Sub test()

Dim lastrow As Long, lastrow2 As Long
Dim i As Integer, j As Integer
Dim PatternFound As Boolean

Call speedup

lastrow = Sheets("Keywords").Range("A" & Rows.Count).End(xlUp).Row
lastrow2 = Sheets("SOURCE DATA").Range("E" & Rows.Count).End(xlUp).Row


For i = 4 To lastrow2

PatternFound = False

    j = 1

Do While PatternFound = False And j < lastrow

    j = j + 1

            If UCase(Sheets("SOURCE DATA").Range("E" & i).Value) Like "*" & UCase(Sheets("Keywords").Range("A" & j).Value) & "*" Then
                Sheets("SOURCE DATA").Range("F" & i).Value = Sheets("Keywords").Range("B" & j).Value
                PatternFound = True
            End If

  Loop

Next i

Call normal

End Sub

Public Sub speedup()

Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
End Sub

Public Sub normal()

Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True

End Sub