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

 

[jackal764u]

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.

Tx. Here goes the XL2BB attempt

First is the "Orig Memo + New cat" sheet

Report Experiments V11 Test from MrExcel.xlsm
	C	D	E	F
1327	Vehicle Repayments	Vehicle Repayments	Polo TDi	Polo Tdi Settlement
1328	Maintenance	Maintenance		Glass
1329	Healthcare	Healthcare	Pharmacy	Pha
1330	Pets	Pets		Pet
1331	Fuel	Fuel		Service Centr
1332	Fuel	Fuel		Service Centr
1333	Fuel	Fuel		Service Centr
1334	Fuel	Fuel		Service Centr
1335	Fuel	Fuel		Service Centr
1336	Fuel	Fuel		Service Centr
1337	Fuel	Fuel		Service Centr
1338	Sanbonani Expenses	Sanbonani Expenses	Car Rental	Rent A Car
1339	Fuel	Fuel		Service Centr
1340	Len Salary	Len Salary	Hydro Doors	Cams Payment FNB
1341	Len Salary	Len Salary	Hydro Doors	Cams Payment FNB
1342	Len Salary	Len Salary	Hydro Doors	Cams Payment FNB
1343	Len Salary	Len Salary	Hydro Doors	Cams Payment FNB
1344	Len Salary	Len Salary	Hydro Doors	Cams Payment FNB
1345	Len Salary	Len Salary	Hydro Doors	Cams Payment FNB
1346	Len Salary	Len Salary	Hydro Doors	Cams Payment FNB
1347	Len Salary	Len Salary	Hydro Doors	Cams Payment FNB
1348	Fuel	Fuel		Motor
1349	Fuel	Fuel		Service Centr
1350	Interest	Interest	Len Cheque FNB	INT
1351	Interest	Interest	Len Cheque FNB	INT
1352	Fuel	Fuel		Service Centr
1353	Fuel	Fuel		Motor
1354	Healthcare	Healthcare	Pharmacy	ESSENTIAL HEALTH
1355	Healthcare	Healthcare	Pharmacy	ESSENTIAL HEALTH
1356	Healthcare	Healthcare	Pharmacy	ESSENTIAL HEALTH
Orig Memo + New cat

This is the "Keywords" sheet

Report Experiments V11 Test from MrExcel.xlsm
	C	D	E	F
2650	Vehicle Repayments	Vehicle Repayments	Polo TDi	Polo Tdi Settlement
2651	Groceries	Groceries		Polokwane ZA
2652	Groceries	Groceries		POPPIES
2653	Restaurant	Restaurant		PORTERHOUSE
2654	Maintenance	Maintenance		C"pennypinchers
2655	Groceries	Groceries
2656	Sanbonani Expenses	Sanbonani Expenses	Stationery	Post Office
2657	General Expense	General Expense	Stationery	Postnet
2658	Take Away	Take Away		Potbelly
2659	Leisure And Entertainment	Leisure and entertainment	Lotto	POWERBALL
2660	Vehicle Maintenance	Vehicle Maintenance	Exhaust	POWERFLOW
2661	Tech Goods	Tech Goods		Poynting
2662	Groceries	Groceries		Pp*4856code
2663	Inter Account Transfer From	Inter Account Transfer From	Len Cheque FNB	Premier Cheque
2664	Bank Fees	Bank Fees	Card Fee	prepaid airtime fee
2665	Groceries	Groceries		President Hyper
2666	Healthcare	Healthcare	Pharmacy	Priarnnacy
2667	Sanbonani Expenses	Sanbonani Expenses	Airline Tickets	Primacare
2668	Fuel	Fuel		Prime Stop
2669	Take Away	Take Away		Primi PiattI
2670	Sanbonani Expenses	Sanbonani Expenses	Fuel	Princess Palace
2671	Bank Fees	Property Service Provider	Advertising	Private Property
2672	Computer	Computer	Computer Hardware	Pro Graphics
2673	Leisure And Entertainment	Leisure and entertainment	Sports Equipment	Pro Shop
2674	Sanbonani Expenses	Sanbonani Expenses	Tender Doc	PROJECTS
2675	Property Service Provider	Property Service Provider	Trust Fees	Prokereur
2676	Fuel	Fuel		Proper Serv
2677	Rent	Rent	Silverfields	Proprent
2678	Healthcare	Healthcare	Pharmacy	PROTEA HOOGTE BRACKENFELL ZA
2679	Healthcare	Healthcare	Psychiatrist	Psych
Keywords

 

[Fluff]

Thanks for that, can you re-post the data for the Orig Memo + New cat sheet, including col B?

 

[jackal764u]

Thanks for that, can you re-post the data for the Orig Memo + New cat sheet, including col B?

Sorry, my mistake

Report Experiments V11 Test from MrExcel.xlsm
	B	C	D	E	F
1327	1bb Polo Tdi Settlement Vods65dx8 9YB	Vehicle Repayments	Vehicle Repayments	Polo TDi	Polo Tdi Settlement
1328	75221004258000000970042 C*Bellville Glass Cent	Maintenance	Maintenance		Glass
1329	75412834086000180038062 Klein Panorama Pharm President Swart Str	Healthcare	Healthcare	Pharmacy	Pha
1330	Absolute Pets Century Century City ZA	Pets	Pets		Pet
1331	Basson’s Service Centr Witpoorijie ZA	Fuel	Fuel		Service Centr
1332	Basson’s Service Centr Witpoortjie ZA	Fuel	Fuel		Service Centr
1333	Basson�s Service Centr Witpoortjie ZA	Fuel	Fuel		Service Centr
1334	Basson's Service Centr Witooortiie ZA	Fuel	Fuel		Service Centr
1335	Basson's Service Centr Witpoorijie ZA	Fuel	Fuel		Service Centr
1336	Basson's Service Centr Witpoortjie ZA	Fuel	Fuel		Service Centr
1337	Basson's Service Centr Witpoortjie ZA ,	Fuel	Fuel		Service Centr
1338	Budget Rent A Car Isando ZA	Sanbonani Expenses	Sanbonani Expenses	Car Rental	Rent A Car
1339	C*basson's Service Centr Witpoortjie ZA	Fuel	Fuel		Service Centr
1340	Cams Payment FNB Cams Pay 00568 Salary	Len Salary	Len Salary	Hydro Doors	Cams Payment FNB
1341	Cams Payment FNB Cams Pay 00575 Salary	Len Salary	Len Salary	Hydro Doors	Cams Payment FNB
1342	Cams Payment FNB Cams Pay 00583 Salary	Len Salary	Len Salary	Hydro Doors	Cams Payment FNB
1343	Cams Payment FNB Cams Pay 00591 Salary	Len Salary	Len Salary	Hydro Doors	Cams Payment FNB
1344	Cams Payment FNB Cams Pay 00599 Salary	Len Salary	Len Salary	Hydro Doors	Cams Payment FNB
1345	Cams Payment FNB Cams Pay 00607 Salary	Len Salary	Len Salary	Hydro Doors	Cams Payment FNB
1346	Cams Payment FNB Cams Pay 00615 Salary	Len Salary	Len Salary	Hydro Doors	Cams Payment FNB
1347	Cams Payment FNB Cams Pay 00623 Salary	Len Salary	Len Salary	Hydro Doors	Cams Payment FNB
1348	Circle Centre Motors F Monavoni ZA	Fuel	Fuel		Motor
1349	Clive's Service Centre Isando ZA	Fuel	Fuel		Service Centr
1350	Electronlc Payments Bis/Int 1 On True Tiering = 6.30	Interest	Interest	Len Cheque FNB	INT
1351	Electronlc Payments Bis/Int 4 On True llerlng = 33.20	Interest	Interest	Len Cheque FNB	INT
1352	Empire Service Centre Bassonia ZA	Fuel	Fuel		Service Centr
1353	Enterpirse Motors Johannesburg ZA	Fuel	Fuel		Motor
1354	Essential Health Phy Kac Kuils River	Healthcare	Healthcare	Pharmacy	ESSENTIAL HEALTH
1355	ESSENTIAL HEALTH PHY KACKUILS RIVER	Healthcare	Healthcare	Pharmacy	ESSENTIAL HEALTH
1356	ESSENTIAL HEALTH PR 400974*8637 05 JUN	Healthcare	Healthcare	Pharmacy	ESSENTIAL HEALTH
Orig Memo + New cat

 

[Fluff]

Thanks for that, the problem is that F2655 is blank which is causing the problem, this will ignore any rows where col F is blank

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 Ary(i, 4) <> "" And 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]

Thanks for that, the problem is that F2655 is blank which is causing the problem, this will ignore any rows where col F is blank

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 Ary(i, 4) <> "" And 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

I was not aware that it could cause errors (F2655). Sorry.

Thank you so much for your assistance and expertise!
Your solution is exactly what was required. It is accurate, correct and effective.
You have cut the macro time from 3 minutes to below 30 seconds.

I commend you on your expertise and willingness to help.

 

[Fluff]

You're welcome & thanks for the feedback.