Increase the execution speed of VBA macro code

Question

I am providing you with the code of my macro and hope that somebody can tell me what is making my macro slow and provide me with a solution as to how to make it run faster. Currently the execution of this code is taking ~ 1 min to finish but I still need to improve the execution time, any help will be highly appreciated. Below is the code:

Dim con As ADODB.Connection
Dim rs As ADODB.Recordset
Dim query As String
Dim Fond As String
Dim KontoNr As String
Dim StartDate As Date
Dim EndDate As Date
Dim wb As Workbook

  Dim wr As Worksheet
  Dim ws As Worksheet
  Dim wt As Worksheet


Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False

  Set wb = ActiveWorkbook
  Set wr = Sheets("Fee")
  Set ws = Sheets("TestExecution")
  Set wt = Sheets("Results_Overview")



  'wr.UsedRange.Interior.ColorIndex = 0
  With wr.UsedRange
    RowCount = .Rows.Count
    If (RowCount > 1) Then
    wr.Range(2 & ":" & RowCount).EntireRow.Delete
    End If
  End With


  With wt.UsedRange
    RowCount = .Rows.Count
    If (RowCount > 2) Then
    wt.Range(2 & ":" & RowCount).EntireRow.Delete
    End If
  End With

  With ws.UsedRange
  ws.Range(Cells(2, 1), Cells(.Rows.Count, 1)).ClearContents
  ws.Range(Cells(2, 6), Cells(.Rows.Count, 15)).ClearContents

  End With


  Dim r As Long
  Dim Count As Integer
  Dim a As Integer
  Dim Counter As Integer



Set con = New ADODB.Connection
Set rs = New ADODB.Recordset


PeriodStartDate = ws.Cells(2, 4).Value
PeriodEndDate = ws.Cells(3, 4).Value
KontoNr = ws.Cells(4, 4).Value

Count = DatePart("d", PeriodEndDate)


strCon = "Provider=SQLOLEDB; " & _
        "Data Source= XXX;" & _
        "Initial Catalog=XX;" & _
        "Integrated Security=SSPI"

con.Open (strCon)
query = "SELECT distinct Fond FROM RI_Trans_Akt ta WITH (NOLOCK) WHERE cast(ta.Avslutsdag as date) < '" & PeriodEndDate & "'"
rs.Open query, con, adOpenStatic
con.Execute query
Counter = rs.RecordCount
ws.Cells(2, 1).CopyFromRecordset rs
rs.Close
con.Close


Dim p As Long
Dim lp As Long
For p = 2 To Counter + 1
StartDate = ws.Cells(2, 4).Value
a = wr.Range("A" & wr.Rows.Count).End(xlUp).Row
For r = 1 To Count

Fond = ws.Cells(p, 1).Value
wr.Cells(a + r, 1).Value = Fond
wr.Cells(a + r, 2).Value = StartDate
wt.Cells(a + r, 1).Value = Fond
wt.Cells(a + r, 2).Value = StartDate
DateFormat = Format(StartDate, "yyyymmdd")


con.Open (strCon)
query = "select Totalt_Antal_Andelar,Forvaltnings_avgift,CAST(Forvaltnings_avgift_kurs AS NUMERIC(30,10)) AS Forvaltnings_avgift_Kurs from ri_fond_avgift WITH (NOLOCK) where Datum = '" & StartDate & "' and Fond = '" & Fond & "'"
rs.Open query, con
con.Execute query
If (rs.RecordCount > 0) Then
wr.Cells(a + r, 3).Value = rs.Fields(0)
wr.Cells(a + r, 4).Value = rs.Fields(1)
wr.Cells(a + r, 5).Value = rs.Fields(2)
Else
wr.Cells(a + r, 3).Value = "0.00"
wr.Cells(a + r, 4).Value = "0.00"
wr.Cells(a + r, 5).Value = "0.00"
End If
rs.Close


query = "SELECT ta.KontoNr,Sum (Antal_andelar) FROM RI_Trans_Akt ta WITH (NOLOCK) WHERE ta.Kontonr = '" & KontoNr & "' and cast(ta.Avslutsdag as date) < '" & StartDate & "' and ta.Fond = '" & Fond & "' and ta.Mak_dag is null Group BY ta.Kontonr,ta.Fond"
rs.Open query, con, adOpenStatic
con.Execute query
If (rs.RecordCount > 0) Then
wr.Cells(a + r, 6).Value = rs.Fields(0)
wr.Cells(a + r, 7).Value = rs.Fields(1)
Else
wr.Cells(a + r, 7).Value = "0.00"
End If
rs.Close

con.Close

StartDate = DateAdd("d", 1, StartDate)

Next r

Dim i As Integer
For i = a + 1 To Count + a
If (wr.Cells(i, 3).Value <> 0) Then
wr.Cells(i, 8).Value = wr.Cells(i, 5).Value * wr.Cells(i, 7).Value
wt.Cells(i, 3).Value = wr.Cells(i, 8).Value

Else
wr.Cells(i, 5).Value = "0.00"
wr.Cells(i, 8).Value = "0.00"
wt.Cells(i, 3).Value = "0.00"
End If

Next i

Dim j As Integer
Dim totalManagementFee As Double
totalManagementFee = 0
For j = a + 1 To Count + a
totalManagementFee = totalManagementFee + wr.Cells(j, 8).Value
Next j
ws.Cells(p, 7).Value = totalManagementFee
ws.Cells(p, 6).Value = Fond

Next p

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.EnableEvents = True
ActiveSheet.DisplayPageBreaks = True

End Sub

Answer 1

After having a short look at your code, I get the impression that your database accesses in a double loop are the cause of the long execution time.

First of all, it is generally much faster to pull all necessary data from a database in one go into memory and to assign the specific points of data to their correct place later.

Moreover, to make optimal use of the database engine, you have to be cautious with conditions. Casting on a database column inside a condition, generally eliminates the possibility to use an index for fast access. Thus, most likely you will get a full table scan. Accordingly, you might want to think about how to change your date condition to eliminate the cast.

The next thing I observe is that you close and reopen the database connection in the loop. Establishung connections is rather expensive. So, you should open it once, reuse it and then close it at the end of your procedure.

Talking about the connection, you seem to execute all queries twice. There is no need to first open a record set and then execute the query again throwing the result away. You can simply set the result to the record set without opening it. Set rs = con.Execute(query)

Now, let me give some more remarks nit concerning performance.

Your code could really benefit from proper indentation. With it how deep your queries are in the loops would be immediately apparent.

Another thing that might be good for anybody maintaining the code would be to split it into several procedures and functions clearly separating the different jobs performed in this large procedure. With good names, this can help readibility a long way.

There are probably a few more things but I will leave it at this.