How to increase the execution speed of my VBA macr

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

ok, so you are reading and writing from and to the range, you should do this once and not in a loop. Also, deleting rows one by one will take much time and you don't need to do this. Use arrays, convert a range to an array first and then execute all of your validations and manipulation etc on the array first and once done, just paste the array to the range.

to change a range to an array simply do this:

Dim i, j As Long
Dim arr() As Variant
Dim rng As Range

Set rng = Worksheet.Range("A1:B10") 'define your range as you wish
arr = rng.Value

'access all cell values inside the array now
For i = 1 To UBound(arr, 1)
    For j = 1 To UBound(arr, 2)
        'do whatever you want to do in the array
    Next j
Next i

'paste back the new values to the range
rng.Value = arr

also you are running the same query twice with different functions: rs.Open query, con, adOpenStatic 'returns a recordset con.Execute query 'does not return a recordset

delete the second line, you don't need it

you are opening and closing the same connection more than once, whike you need to open the connection once before executing any of your SQL queries and close it at the end of it.

con.open
' run all sql queries, no need to close the connection unless you have a very specific purpose for it 
con.close
set con=nothing

also instead of looping through a recordset, dump your data in an array and then loop through the array, it is a lot faster and more stable:

array = recordset.GetRows(Rows, Start, Fields )