Quicker method to run macro for keywords

[jackal764u]

Hello and thank you for a most helpful excel site.

This macro looks for keywords in a memo column and replaces adjacent columns with applicable content from a keyword sheet.
The memo column contains 14300 rows to search and match to 3500 rows in keyword column.
This is on windows 7 and Excel 2010 Pro
It takes the macro just under 3 minutes to complete. Is it possible to make it quicker?

Sub AddCategories2()
Dim wsIDs As Worksheet, Keywords As Range, Word As Range
Dim kFIND As Range, kFIRST As Range

Application.ScreenUpdating = False
'Choose Active Sheet Below
Set wsIDs = Sheets("Keywords")
'Where to Find the Keywords
Set Keywords = wsIDs.Range("F2:Z" & Rows.Count).SpecialCells(xlConstants)

On Error Resume Next
'Choose Active Sheet
With Sheets("Orig Memo + New cat")
    If MsgBox("Reset IDs before running new search?", vbYesNo, "Reset") = vbYes Then .Range("C2:F" & .Rows.Count).ClearContents
    For Each Word In Keywords
'    Find Keywords in Item Description/Memo Column
'        Set kFIND = .Range("B:B").Find(Word.Text, LookIn:=xlValues, LookAt:=xlPart)
        Set kFIND = .Range("B:B").Find(Word.Text, LookIn:=xlValues)
        If Not kFIND Is Nothing Then
            Set kFIRST = kFIND
            Do
                If .Range("C" & kFIND.Row) = "" Then
'                    fill col D(Payee) & E(Cat) & F(SubCat) in Orig Memo + New cat sheet with col D(Payee) & E(Cat) & F(SubCat) from Keywords sheet.
'                    where to paste cols(with C=1)  . 2nd resize is cols to copy from Keywords sheet
                    .Range("C" & kFIND.Row).Resize(, 3).Value = wsIDs.Range("C" & Word.Row).Resize(, 3).Value
                    .Range("F" & kFIND.Row).Resize(, 1).Value = wsIDs.Range("F" & Word.Row).Resize(, 1).Value
                End If
                        
'                Go to Next Row (Loop)
                Set kFIND = .Range("B:B").FindNext(kFIND)
            Loop Until kFIND.Address = kFIRST.Address
            Set kFIRST = Nothing
        End If
    Next Word
End With

Application.ScreenUpdating = True
End Sub

Thank you. Your help is appreciated

 

[Fluff]

Do the keywords only exists in col F or are they in cols F thru Z

 

[jackal764u]

Do the keywords only exists in col F or are they in cols F thru Z

Tx. Only in F

 

[Fluff]

In that case I would change this line as shown

Set Keywords = wsIDs.Range("F2:F" & Rows.Count).SpecialCells(xlConstants)

otherwise you could be searching for text in cols G:Z if there is any

 

[Fluff]

Code removed as it's seriously flawed.
Will repost shortly.

 

[Fluff]

How about

Sub jackal()
   Dim Ary As Variant, Nary As Variant
   Dim r As Long, i As Long
   
   With Sheets("Keywords")
      Ary = .Range("C2", .Range("F" & Rows.Count).End(xlUp)).Value2
   End With
   With Sheets("Orig Memo + New cat")
      If MsgBox("Reset IDs before running new search?", vbYesNo, "Reset") = vbYes Then .Range("C2:F" & .Rows.Count).ClearContents
      Nary = .Range("B2:E" & .Range("B" & Rows.Count).End(xlUp).Row)
   End With
   For r = 1 To UBound(Nary)
      For i = 1 To UBound(Ary)
         If InStr(1, Nary(r, 1), Ary(i, 4), vbTextCompare) Then
            Nary(r, 2) = Ary(i, 1)
            Nary(r, 3) = Ary(i, 2)
            Nary(r, 4) = Ary(i, 3)
            Exit For
         End If
      Next i
   Next r
   Sheets("Orig Memo + New cat").Range("B2").Resize(UBound(Nary), 4).Value = Nary
End Sub

 

[jackal764u]

How about

Sub jackal()
   Dim Ary As Variant, Nary As Variant
   Dim r As Long, i As Long
  
   With Sheets("Keywords")
      Ary = .Range("C2", .Range("F" & Rows.Count).End(xlUp)).Value2
   End With
   With Sheets("Orig Memo + New cat")
      If MsgBox("Reset IDs before running new search?", vbYesNo, "Reset") = vbYes Then .Range("C2:F" & .Rows.Count).ClearContents
      Nary = .Range("B2:E" & .Range("B" & Rows.Count).End(xlUp).Row)
   End With
   For r = 1 To UBound(Nary)
      For i = 1 To UBound(Ary)
         If InStr(1, Nary(r, 1), Ary(i, 4), vbTextCompare) Then
            Nary(r, 2) = Ary(i, 1)
            Nary(r, 3) = Ary(i, 2)
            Nary(r, 4) = Ary(i, 3)
            Exit For
         End If
      Next i
   Next r
   Sheets("Orig Memo + New cat").Range("B2").Resize(UBound(Nary), 4).Value = Nary
End Sub

Tx Fluff
Your first suggestion makes no difference to the macro time
Your second suggestion deletes all contents in the "Orig Memo + New cat" sheet

 

[Fluff]

Your second suggestion deletes all contents in the "Orig Memo + New cat" sheet

Not for me it doesn't, I get the same results as your code gives, except I forgot to add the keyword column to the output, which this handles

Sub jackal()
   Dim Ary As Variant, Nary As Variant
   Dim r As Long, i As Long
   
   With Sheets("Keywords")
      Ary = .Range("C2", .Range("F" & Rows.Count).End(xlUp)).Value2
   End With
   With Sheets("Orig Memo + New cat")
      If MsgBox("Reset IDs before running new search?", vbYesNo, "Reset") = vbYes Then .Range("C2:F" & .Rows.Count).ClearContents
      Nary = .Range("B2:F" & .Range("B" & Rows.Count).End(xlUp).Row)
   End With
   For r = 1 To UBound(Nary)
      For i = 1 To UBound(Ary)
         If InStr(1, Nary(r, 1), Ary(i, 4), vbTextCompare) Then
            Nary(r, 2) = Ary(i, 1)
            Nary(r, 3) = Ary(i, 2)
            Nary(r, 4) = Ary(i, 3)
            Nary(r, 5) = Ary(i, 4)
            Exit For
         End If
      Next i
   Next r
   Sheets("Orig Memo + New cat").Range("B2").Resize(UBound(Nary), 5).Value = Nary
End Sub

 

[jackal764u]

Tx. Your amendment fixed the disappearence of all contents in the "Orig Memo + New cat" sheet.
The macro copies over the incorrect adjacent columns because it uses the wrong keyword (I think).
One important comment is that the "KW to categorise" column contains spaces in before and/or after all text:
this was to ensure that some keywords were not interpreted as a part of another keyword,
i.e. "spar supermarket" is not read as "spares shop". The keywords (in bold here), refer to different categories
spar = groceries and spares = vehicle maintenance, thus spar gets a space after itself in the "KW to categorise" column
not to be read as part of spares
I don't know if your macro takes these spaces in consideration

 

[Fluff]

Yes, the code should take those spaces into consideration, although it is not case-sensitive (not sure if that's a problem).

Can you post some sample data from both sheets that demonstrates the problem.

MrExcel has a tool called “XL2BB” that lets you post samples of your data that will allow us to copy/paste it to our Excel spreadsheets, so we can work with the same copy of data that you are. Instructions on using this tool can be found here: XL2BB Add-in

Note that there is also a "Test Here” forum on this board. This is a place where you can test using this tool (or any other posting techniques that you want to test) before trying to use those tools in your actual posts.