Better approach to text-based lookup tables? Currently too slow.

[thedoctor00]

Dear masters of excel,

I've recently had some help creating a VBA script that essentially runs through 3 or 4 look-up tables, looking for partial text matches within a column (circa 2000-20000 rows depending on raw data) and returning corresponding return values.

It functions correctly but the process takes circa 5-10 minutes to complete, which is far too long to be workable (2-3 mins would make it usable).

Is there a better way of doing this?

Thank you all.

Public mystring As String
Public commentlp As Long
Public commentlrow As Long

Sub Check_Location()

Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False

Worksheets("Data Sheet").Activate

'''' LOOKUP FOR LOCATION

'''Some application functions to speed up the macro

Dim wrdLRow As Long

Dim x As Long

Dim Sht, ws, wt, wu, wv As Worksheet

Set ws = Sheets("Location")

wrdLRow = ws.Cells(Rows.Count, "A").End(xlUp).Row

'--- Connect to the current datasource of the Excel file

' On Error Resume Next 'Suppress Errors... for when we don't find a match

'Define worksheet that has data on it....

Set Sht = Sheets("Data Sheet")

'Get last row for words in Location based on column A

wrdLRow = ws.Cells(Rows.Count, "A").End(xlUp).Row

'Get last row for Description in Data Sheet based on column C

commentlrow = Sht.Cells(Rows.Count, "C").End(xlUp).Row

With Sht

'Loop through rows in data sheet

For commentlp = 2 To commentlrow

'Store the description in column C

'Set the value we want to check for in Column D. You can edit the value as necessary

myvalue = 0.1

' sql = "SELECT * FROM [Location$A1:E" & wrdLRow & "] "

'

' '--- Run the SQL query

' Set result = connection.Execute(sql)

'

' Do

' output = result(4)



mystring = .Cells(commentlp, 3)

' If InStr(mystring, result(0)) > 0 And .Cells(commentlp, 5) = "" And result(4) = ">" And .Cells(commentlp, 4) > myvalue Then

' .Cells(commentlp, 5) = result(1)

' ElseIf InStr(mystring, result(0)) > 0 And .Cells(commentlp, 5) = "" And result(4) = "<" And .Cells(commentlp, 4) < myvalue Then

' .Cells(commentlp, 5) = result(1)

' ElseIf InStr(mystring, result(0)) > 0 And .Cells(commentlp, 5) = "" And result(4) = "equals" And .Cells(commentlp, 4) = myvalue Then

' .Cells(commentlp, 5) = result(1)

' ElseIf InStr(mystring, result(0)) > 0 And .Cells(commentlp, 5) = "" And (result(4) = "" Or IsNull(result(4))) Then

' .Cells(commentlp, 5) = result(1)

' End If

' Next

'

' result.movenext

' Loop Until result.EOF

'Sht.Cells(commentlp, 5) = result(0)


'Loop through Location word list

With ws

Dim iAmount() As Variant

Dim iNum As Long

iAmount = .Range(.Cells(2, 1), .Cells(wrdLRow, 5)).Value2

For iNum = 1 To UBound(iAmount, 1)

' 'Debug.Print iAmount(iNum, 1)

'If InStr(mystring, iAmount(iNum, 1)) > 0 Then

' For x = 2 To wrdLRow

' 'If we find a match and no threshold set, copy it across

If InStr(mystring, iAmount(iNum, 1)) > 0 And iAmount(iNum, 5) = "" Then

Sht.Cells(commentlp, 5) = iAmount(iNum, 2)

Exit For

' 'If we find a match and a threshold is set, check Column D against the value we set earlier (myvalue) - greater than

ElseIf InStr(mystring, iAmount(iNum, 1)) > 0 And InStr(iAmount(iNum, 5), ">") > 0 And Sht.Cells(commentlp, 4) > myvalue Then

Sht.Cells(commentlp, 5) = iAmount(iNum, 2)


Exit For

' 'If we find a match and a threshold is set, check Column D against the value we set earlier (myvalue) - less than

ElseIf InStr(mystring, iAmount(iNum, 1)) > 0 And InStr(iAmount(iNum, 5), "<") > 0 And Sht.Cells(commentlp, 4) <= myvalue Then

Sht.Cells(commentlp, 5) = iAmount(iNum, 2)

Exit For

ElseIf InStr(mystring, iAmount(iNum, 1)) > 0 And InStr(iAmount(iNum, 5), "equals") > 0 And Sht.Cells(commentlp, 4) = myvalue Then

Sht.Cells(commentlp, 5) = iAmount(iNum, 2)

Exit For

Else

' 'Leave blank if no match

Sht.Cells(commentlp, 5) = ""

End If

'Else

'End If

Next iNum

' Next x

'
End With


' Get the Party Column

If .Cells(commentlp, 5) = "pw_att" Or .Cells(commentlp, 5) = "pw_ltc" Or .Cells(commentlp, 5) = "pw_tc" Or .Cells(commentlp, 5) = "pw_lo" Or .Cells(commentlp, 5) = "pw_eo" Then

''' Goes to the Party script below

Call Check_Party

Else

End If

' Get the Tasks Column

' Goes to the Tasks script below

Call Check_Tasks

' Goes to the Activity Script below

' Get the Activity Column

Call Check_Activity

' Goes to the Phase script below

' Get the Phase Column

Call Check_Phase

Next commentlp

End With


Application.ScreenUpdating = True

Application.EnableEvents = True

Application.Calculation = xlCalculationAutomatic

Application.DisplayAlerts = True

MsgBox "Automation successful."

End Sub








Sub Check_Party()

' Code for the Party lookup

Dim wrdLRow As Long

Dim x As Long

Dim Sht, ws, wt, wu, wv As Worksheet



On Error Resume Next 'Suppress Errors... for when we don't find a match



'Define worksheet that has data on it....

Set Sht = Sheets("Data Sheet")

Set ws = Sheets("Party")



'Get last row for words in Party based on column A

wrdLRow = ws.Cells(Rows.Count, "A").End(xlUp).Row

With ws

For x = 2 To wrdLRow

'If we find a match copy it across

If InStr(mystring, .Cells(x, 1)) > 0 Then

Sht.Cells(commentlp, 6) = .Cells(x, 2)

Exit For

Else

'Leave blank if no match

Sht.Cells(commentlp, 6) = ""

End If

Next x

End With

End Sub






Sub Check_Tasks()



' Code for the Tasks lookup table

Dim wrdLRow As Long

Dim x As Long

Dim Sht, ws, wt, wu, wv As Worksheet

On Error Resume Next 'Suppress Errors... for when we don't find a match

'Define worksheet that has data on it....

Set Sht = Sheets("Data Sheet")

Set ws = Sheets("Tasks")

'Get last row for words in Party based on column A

wrdLRow = ws.Cells(Rows.Count, "A").End(xlUp).Row

With ws

For x = 2 To wrdLRow

'If we find a match copy it across

If InStr(mystring, .Cells(x, 1)) > 0 Then

Sht.Cells(commentlp, 9) = .Cells(x, 2)

Exit For

Else

'Leave blank if no match

Sht.Cells(commentlp, 9) = ""

End If

Next x

End With
End Sub





Sub Check_Activity()
' Code for the Activity lookup table

Dim wrdLRow As Long
Dim x As Long
Dim Sht, ws, wt, wu, wv As Worksheet

On Error Resume Next 'Suppress Errors... for when we don't find a match

'Define worksheet that has data on it....

Set Sht = Sheets("Data Sheet")

Set ws = Sheets("Activity")

'Get last row for words in Party based on column A

wrdLRow = ws.Cells(Rows.Count, "A").End(xlUp).Row

With ws

For x = 2 To wrdLRow

'If we find a match copy it across

If .Cells(x, 1) = Sht.Cells(commentlp, 5) And .Cells(x, 2) = Sht.Cells(commentlp, 6) Then

Sht.Cells(commentlp, 10) = .Cells(x, 3)

Exit For

Else

'Leave blank if no match

Sht.Cells(commentlp, 10) = ""

End If

Next x

End With

End Sub

Sub Check_Phase()

' Code for the Phase lookup table

Dim wrdLRow As Long

Dim x As Long

Dim Sht, ws, wt, wu, wv As Worksheet

On Error Resume Next 'Suppress Errors... for when we don't find a match

'Define worksheet that has data on it....

Set Sht = Sheets("Data Sheet")

Set ws = Sheets("Phase")

'Get last row for words in Party based on column A

wrdLRow = ws.Cells(Rows.Count, "A").End(xlUp).Row

With ws

For x = 2 To wrdLRow

'If we find a match copy it across

If Sht.Cells(commentlp, 9) = .Cells(x, 1) Then

Sht.Cells(commentlp, 8) = .Cells(x, 2)

Exit For

Else

'Leave blank if no match

Sht.Cells(commentlp, 8) = ""

End If

Next x

End With
End Sub

 

[Marc L]

Is there a better way of doing this?

Maybe with a filter or an advanced filter, that depends on the data worksheet design …​

 

[offthelip]

You seem to be using a variant array for your input but NOT using variant array for your outputs; you have lots of instances of code like this:

Sht.Cells(commentlp, 5) =  something

all of these are going to take a long time because they are writing to the workhseet specially as they are in a double loop , so change all of these outputs to write to a variant array and write the array back at the end, that will make a huge difference