Excel VBA Redshift Query Performance Improvements

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.

user_12704593 · Answer

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

user_14152989 · Answer

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

Excel VBA Redshift Query Performance Improvements

2 Answers