jackal764u
New Member
- Joined
- Jul 15, 2019
- Messages
- 11
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?
Thank you. Your help is appreciated
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?
VBA Code:
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