Excel VBA Redshift Query Performance Improvements - excel

Question

I have an excel macro enabled workbook which offers the user the option of entering some parameters to use in the query as filter (WHERE) clauses. This in turn is supplied to the queries. I have about 3 queries which do not use the filters and 4 OR 5 depending on which filters are chosen that run using filters. The query complexity varies.
The queries are run against a Redshift Cluster. (All of the data is confidential and the RS is internal connection only, so I can't give the entire query or anything, just examples)
The 3 small queries are 1-2 lines.
3 or 4 of the remaining 5 are about 40 lines
5th is about 100.
When run directly on the cluster with no filters: returns ~42400 rows and 23 Columns
3 small queries run and load to the excel file in less than 3 seconds or so each
Medium query 1: On Cluster - ~1 Seconds
Medium Query 2: On Cluster ~5 Seconds
Medium Query 3: On Cluster - ~9 Seconds
Large Query 1: On Cluster - ~24 seconds
Now here in lies the issue, when I run these queries in vba using the following for each query to update a listboject (example code) it takes 980.59 (~16.4 Minutes) Seconds
CS = "ODBC;Driver={Amazon Redshift (x64)};SERVER={RS1.us-east-1.redshift.amazonaws.com};PORT=8192;DATABASE=db1;UID=user;PASSWORD=fakepasswrod;sslmode=require"
With Sheet2.ListObjects.Add(SourceType:=0, Source:=CS, Destination:=Sheet2.Range("$A$1")).QueryTable
.CommandText = Sql
.RefreshStyle = xlInsertDeleteCells
.AdjustColumnWidth = True
.ListObject.DisplayName = "Name_of_LO_1"
.Refresh BackgroundQuery:=False
End With
In addiiton, I have to give the users the ability to do Wildcards, Comma Separated Lists, and single entries to filters. That part doesn't take long to build from the cell values.
I have to build the filters with large if statements similar to the one as follows
'Filter Fields
C_List = UCase(ThisWorkbook.Sheets(Sheet1.Name).Range("D1").Value)
S_List = UCase(ThisWorkbook.Sheets(Sheet1.Name).Range("D2").Value)
F_List = UCase(ThisWorkbook.Sheets(Sheet1.Name).Range("D3").Value)
s_year = ThisWorkbook.Sheets(Sheet1.Name).Range("D4").Value
Scen = "'" & ThisWorkbook.Sheets(Sheet1.Name).Range("D5").Value & "'"
prior_s_year_1 = "'" & ThisWorkbook.Sheets(Sheet1.Name).Range("D6").Value & "'"
prior_Scen_1 = "'" & ThisWorkbook.Sheets(Sheet1.Name).Range("D7").Value & "'"
prior_s_year_2 = "'" & ThisWorkbook.Sheets(Sheet1.Name).Range("D8").Value & "'"
prior_Scen_2 = "'" & ThisWorkbook.Sheets(Sheet1.Name).Range("D9").Value & "'"
cat = UCase(ThisWorkbook.Sheets(Sheet1.Name).Range("D10").Value)
subcat = UCase(ThisWorkbook.Sheets(Sheet1.Name).Range("D11").Value)
If Site_List = "" And Cluster_List = "" And FBN_List = "" Then
response = MsgBox("You have chosen no Site, Cluster or FBN filters, this will pull all data and may take some time" & vbNewLine & "Do you wish to continue?", vbYesNo)
If response = vbNo Then
Call MsgBox("Exiting data retrieval, please enter Site, Cluster or FBN filters and restart", vbOKOnly)
Call DeleteConnections
Exit Sub
End If
ElseIf C_List = "ALL" Then
UserDefinedFilters = " bd.reg IN ( SELECT DISTINCT c FROM att_1 ) "
ElseIf S_List <> "" And C_List <> "" And F_List <> "" Then
S_List = Replace(S_List, ", ", ",")
C_List = Replace(C_List, ", ", ",")
F_List = Replace(F_List, ", ", ",")
UserDefinedFilters = UserDefinedFilters & " UPPER(s) in ('" & Replace(S_List, ",", "','") & "')" & _
vbNewLine & " AND UPPER(reg) in ('" & Replace(C_List, ",", "','") & "')" & _
vbNewLine & " AND UPPER(f) in ('" & Replace(F_List, ",", "','") & "')"
ElseIf S_List <> "" And C_List <> "" And F_List = "" Then
S_List = Replace(S_List, ", ", ",")
Cluster_List = Replace(C_List, ", ", ",")
UserDefinedFilters = UserDefinedFilters & " UPPER(s) in ('" & Replace(S_List, ",", "','") & "')" & _
vbNewLine & " AND UPPER(reg) in ('" & Replace(C_List, ",", "','") & "')"
ElseIf S_List <> "" And C_List = "" And F_List = "" Then
S_List = Replace(S_List, ", ", ",")
UserDefinedFilters = UserDefinedFilters & " UPPER(s) in ('" & Replace(S_List, ",", "','") & "')"
ElseIf S_List = "" And C_List <> "" And F_List = "" Then
C_List = Replace(C_List, ", ", ",")
UserDefinedFilters = UserDefinedFilters & " UPPER(reg) in ('" & Replace(C_List, ",", "','") & "')"
ElseIf S_List = "" And C_List = "" And F_List <> "" Then
If InStr(1, F_List, ",") > 0 Then
F_List = Replace(F_List, ", ", ",")
UserDefinedFilters = UserDefinedFilters & " UPPER(bd.f) in ('" & Replace(UCase(F_List), ",", "','") & "')"
ElseIf InStr(1, F_List, "*") > 0 Then
UserDefinedFilters = UserDefinedFilters & " UPPER(bd.f) LIKE '%" & Replace(UCase(F_List), "*", "") & "%'"
ElseIf InStr(1, F_List, "ABC") > 0 Then
UserDefinedFilters = UserDefinedFilters & " UPPER(bd.f) LIKE '%" & UCase(Left(F_List, 12)) & "%'"
Else
UserDefinedFilters = UserDefinedFilters & " UPPER(bd.f) in ('" & UCase(F_List) & "')"
End If
ElseIf S_List = "" And C_List <> "" And F_List <> "" Then
If InStr(1, F_List, ",") > 0 Then
F_List = Replace(F_List, ", ", ",")
UserDefinedFilters = UserDefinedFilters & " UPPER(bd.f) in ('" & Replace(UCase(F_List), ",", "','") & "')"
ElseIf InStr(1, F_List, "*") > 0 Then
UserDefinedFilters = UserDefinedFilters & " UPPER(bd.f) LIKE '%" & Replace(UCase(F_List), "*", "") & "%'"
Else
UserDefinedFilters = UserDefinedFilters & " UPPER(bd.f) in ('" & UCase(F_List) & "')"
End If
End If
'Cat and SubCat Filters
If cat <> "" And subcat <> "" Then
cat = Replace(cat, ",", "','")
subcat = Replace(subcat, ",", "','")
BCSFilters = BCSFilters & " AND UPPER(sca.cat) IN ('" & cat & "')" & _
vbNewLine & "AND UPPER(sca.subcat) in ('" & subcat & "')"
ElseIf cat <> "" And subcat = "" Then
cat = Replace(cat, ",", "','")
BCSFilters = BCSFilters & " AND UPPER(sca.cat) IN ('" & cat & "')"
ElseIf cat = "" And subcat <> "" Then
subcat = Replace(subcat, ",", "','")
BCSFilters = BCSFilters & " AND UPPER(sca.subcat) IN ('" & subcat & "')"
End If
The above is only two sets, but it should give you the idea of what I am having to do for building the where clause.
I cannot find a way to get recordsets working using ADODB and I am not sure if that would be faster or not. I need to do this DSNless if at all possible because the file is used across a wide swath of users. Anything that anyone can think of that might help reduce this huge time in the queries?
EDIT:
Adding the code I attempted for records sets:
Dim conn As Object
Dim rs As Object
Set conn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
CS = "Driver={Amazon Redshift (x64)};DATA SOURCE={RS1.us-east-1.redshift.amazonaws.com};PORT=8192;DATABASE=db1;UID=user;PWD=fakepasswrod;sslmode=require"
conn.Open CS
Set RegAtt = ThisWorkbook.Sheets(Sheet6.Name)
RegAtt.Cells.Clear
RegSql = "SELECT cl,reg,curr FROM schema.table1"
rs.Open RegSql
With RegAtt.ListObjects.Add(xlSrcQuery, rs, Destination:=RegAtt.Range("$A$1")).QueryTable
'.CommandText = RegSql
.RefreshStyle = xlInsertDeleteCells
.AdjustColumnWidth = True
.ListObject.DisplayName = "LO_2"
.Refresh BackgroundQuery:=False
End With
That connection string I get a driver not found error.
This CS = "Driver={Amazon Redshift (x64)};SERVER={RS1.us-east-1.redshift.amazonaws.com};PORT=8192;DATABASE=db1;ID=user;PASSWORD=fakepasswrod;sslmode=require"
I get 3709 - The connection cannot be used to perform this operation. It is either closed or invalid in this context.

Answer 1

This won't change the performance but you may find benefit in adopting a more object-orientated approach to building the queries. For example if you define a class module to hold the parameters and logic, then the build script becomes something like this ;
Sub BuildFilters()
Dim wb As Workbook, ws As Worksheet, response
Set wb = ThisWorkbook
Set ws = wb.Sheets(1)
Const msg1 = "You have chosen no Site, Cluster or FBN filters," & _
"this will pull all data and may take some time" & vbNewLine & _
"Do you wish to continue?"
Const msg2 = "Exiting data retrieval, please enter Site, Cluster or FBN filters and restart"
Dim Qb As New QueryBuilder
Qb.Init ws ' get parameters
If Qb.hasNone Then
response = MsgBox(msg1, vbYesNo)
If response = vbNo Then
Call MsgBox(msg2, vbOKOnly)
'Call DeleteConnections
End If
Else
' build SQL
Qb.BuildUDFilter
Qb.BuildBCSFilters
' dump to sheet to check result
ws.Range("D13") = Qb.UDFilter
ws.Range("D15") = Qb.BCSFilters
End If
End Sub
Class Module QueryBuilder
Option Explicit
Public BCSFilters As String
Public UDFilter As String
Dim C_List As String, hasC As Boolean
Dim S_List As String, hasS As Boolean
Dim F_List As String, hasF As Boolean
Dim s_year As String
Dim Scen As String
Dim prior_s_year_1 As String
Dim prior_Scen_1 As String
Dim prior_s_year_2 As String
Dim prior_Scen_2 As String
Dim cat As String, hasCat As Boolean
Dim subcat As String, hasSubcat As Boolean
Dim count As Integer, hasAny As Boolean
' Initialise Object from Sheet
Sub Init(ws As Worksheet)
With ws
C_List = .Cells(1, 4) ' D1
S_List = .Cells(2, 4)
F_List = .Cells(3, 4)
s_year = Cells(4, 4)
Scen = quoted(.Cells(5, 4))
prior_s_year_1 = quoted(.Cells(6, 4))
prior_Scen_1 = quoted(.Cells(7, 4))
prior_s_year_2 = quoted(.Cells(8, 4))
prior_Scen_2 = quoted(.Cells(9, 4))
cat = .Cells(10, 4)
subcat = .Cells(11, 4)
End With
hasC = CBool(Len(C_List))
hasS = CBool(Len(S_List))
hasF = CBool(Len(F_List))
hasCat = CBool(Len(cat))
hasSubcat = CBool(Len(subcat))
End Sub
Function hasNone() As Boolean
hasNone = Not (hasC Or hasS Or hasF)
End Function
Sub BuildUDFilter()
Dim sql As String
count = 0
If UCase(C_List) = "ALL" Then
sql = " bd.reg IN ( SELECT DISTINCT c FROM att_1 )"
Else
If hasC Then sql = BuildSelect("reg", C_List)
If hasS Then sql = sql & BuildSelect("s", S_List)
If hasF Then sql = sql & BuildSelect("f", F_List)
End If
UDFilter = sql
End Sub
Sub BuildBCSFilters()
Dim sql As String
count = 0
If hasCat Then sql = BuildSelect("sca.cat", cat)
If hasSubcat Then sql = sql & BuildSelect("sca.subcat", subcat)
BCSFilters = sql
End Sub
Private Function BuildSelect(v As String, s As String)
Dim ar As Variant, i As Integer, sql As String
s = UCase(s)
If CBool(InStr(s, "*")) Then
s = Replace(s, "*", "")
sql = " LIKE '%" & s & "%'"
ElseIf CBool(InStr(1, s, "ABC")) Then
s = Left(s, 12)
sql = " LIKE '%" & s & "%'"
Else
ar = Split(s, ",")
For i = 0 To UBound(ar)
ar(i) = Trim(ar(i))
Next
If UBound(ar) = 0 Then
sql = " = '" & ar(0) & "'"
Else
sql = " IN ('" & Join(ar, "','") & "')"
End If
End If
sql = " UPPER(" & v & ")" & sql
If count > 0 Then
sql = vbNewLine & "AND" & sql
End If
count = count + 1
BuildSelect = sql
End Function
Private Function quoted(s) As String
quoted = "'" & s & "'"
End Function

Answer 2

It could be that the line .AdjustColumnWidth = True is contributing to the performance drop? (as it has to load the data to determine auto widths).
Have you considered performing the majority of the code with Application.ScreenUpdating set to False and Application.Calculation set to xlCalculationManual?
For details, see https://www.microsoft.com/en-us/microsoft-365/blog/2009/03/12/excel-vba-performance-coding-best-practices/
This may be worth a try to see if it improves performance. If it does:
You could them put some appropriate user display messages in places for the duration of time that the screen updating is disabled.
Good practice is to store and then restore values for ScreenUpdating and Calculation, so that the environment is left as it was found at the beginning of your subroutine