Code is to slow

[amateur1902]

Dear forum member,

We are building a system to calculate the correlation between different stocks. The system imports data from Bloomberg and the percentage change plus time lag are manually filled in the database (= excel sheet).

The code works quite well, but we are still debugging it (as far as we are capable). Our knowledge of Excel in combination with VBA is very little and it is possible that the code contains 'stupid' mistakes.

The main reason we aks your help for is to help us to make the code faster! We included the progam code (its a pretty long one).

Private Sub CommandButton1_Click()
    Set objDataControl = New BlpData
    Call objDataControl.Flush
 
     'Script weergave uit (niet zichtbaar voor gebruiker)
    Application.ScreenUpdating = False
    'Application.Calculation = xlCalculationManual
 
     '### START
    sngStart = Timer
 
    'Legen van cellen in Excel
    Dim rng As Range
    Set rng = Range("D18:R1000")
    Range(rng, rng).ClearContents
 
    'Opzetten van velden voor array
    arrayFields = Array("PX_LAST")
 
     ' Tickers tellen
    nr_comp = Range(Range("B18"), Range("B18").End(xlDown)).Rows.Count
 
    'Bepaald grote van array
    Dim arraySecurities() As String
    ReDim arraySecurities(nr_comp)
 
    'Leading Fund
    arraySecurities(0) = Range("B10").Value
   ' Range("D18").FormulaR1C1 = "=R[-8]C[-2]"
 
    'Peers (per peer wordt data binnen gehaald)
    With Range("B18")
        i = 1
        Do While i <= nr_comp
            arraySecurities(i) = .Cells(i, 1).Value
            i = i + 1
        Loop
    End With
 
     ' Berekening op basis van dagelijkse koersen
    objDataControl.Periodicity = bbDaily
 
     ' Bepaling data (data uit welke periode)
    startd = Range("D4").Value
    endd = Range("D5").Value
 
    'plaatsen data in excel
    Range("L15").ClearContents
    Range("N15").ClearContents
 
    Range("D5").Select
    Application.CutCopyMode = False
    Selection.Copy
 
    Range("N15").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
 
    Range("D4").Select
    Application.CutCopyMode = False
    Selection.Copy
 
    Range("L15").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
 
    'Instellen datum
    Range("D4").Select
    ActiveCell.FormulaR1C1 = _
        "=DATE(  YEAR(  NOW()  )-R[1]C[3],   MONTH(  NOW()  )-RC[3],  DAY(  NOW()  )-R[-1]C[3]   )"
 
    Range("D5").Select
    ActiveCell.FormulaR1C1 = "=TODAY()"
 
     '#### Bloomberg Connection ####
    objDataControl.GetHistoricalData arraySecurities, 1, arrayFields, _
    CDate(startd), _
    CDate(endd), _
    Results:=vtResult
 
 
     'Tel het aantal data
    nr_of_dates = UBound(vtResult)
 
     'Maak van multi dimentional array een single array (onafhankelijk)
    Dim arr_Id() As Variant
    ReDim arr_Id(nr_of_dates)
    For z = 0 To nr_of_dates
        arr_Id(z) = vtResult(z, 0, 1)
    Next
 
     'Opstellen array voor afhankelijke fondsen
    Dim arr_Dp() As Variant
    ReDim arr_Dp(nr_of_dates)
 
    'Berekening van correlatie
    Dim arrayCorrel() As Variant
    ReDim arrayCorrel(nr_comp)
 
    For a = 0 To nr_comp
        For b = 0 To nr_of_dates
            arr_Dp(b) = vtResult(b, a, 1)
        Next
 
        arrayCorrel(a) = Application.Correl(arr_Id, arr_Dp)
 
        u = a - 1
 
        If Not IsNumeric(arrayCorrel(a)) Then
            arrayCorrel(a) = arrayCorrel(u)
        End If
 
 
        ReDim arr_Dp(nr_of_dates) As Variant
 
    Next
 
     'Filter voor correlaties, niet groter dan 1 of kleiner dan ingestelde parameter
    nrCompz = UBound(arraySecurities)
    corr = Range("D8").Value
    For k = 1 To nrCompz
        'If IsNumeric(arrayCorrel(k)) Then
            If arrayCorrel(k) <> "1" And arrayCorrel(k) > corr Then
                Range("D18").Offset(k, 0).Value = arraySecurities(k)
                Range("H18").Offset(k, 0).Value = arrayCorrel(k)
            End If
        'End If
    Next k
     'Correlatiecoëfficiënt sorteren en invoegen in Excel
    Set rng = Range("D19")
    Range(rng, Range("H10000")).Sort Key1:=Range("H19"), Order1:=xlDescending, _
    Header:=xlNo, _
    OrderCustom:=1, _
    MatchCase:=False, _
    Orientation:=xlTopToBottom, _
    DataOption1:=xlSortNormal
'Vul formules in Excel
Range("D18").Select
ActiveCell.FormulaR1C1 = "=R[-8]C[-2]"
Range("D18").Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Application.CutCopyMode = False
 
    Range("H18").Select
    ActiveCell.FormulaR1C1 = "-"
 
nr_corr = Range(Range("D18"), Range("D18").End(xlDown)).Rows.Count + 17
Range("F18:F" & nr_corr).FormulaR1C1 = "=Proper(BDP(RC[-2]&"" equity"",""name""))"
Range("N18:N" & nr_corr).FormulaR1C1 = "=BDP(RC[-10]&"" equity"",""VOLUME_AVG_30D"")"
Range("P18:P" & nr_corr).FormulaR1C1 = "=BDP(RC[-12]&"" equity"",""last price"")"
Range("R18:R" & nr_corr).FormulaR1C1 = "=(RC[-2]/BDP(RC[-14]&"" equity"",""PX_CLOSE_1D""))-1"
Range("J19:J" & nr_corr).FormulaR1C1 = "=SUMPRODUCT((Data!R2C1:R2000C1=Interface!R18C6)*(Data!R2C3:R2000C3=Interface!R[0]C6)*(Data!R2C4:R2000C4=Data!R1C8)*(Data!R2C6:R2000C6))/SUMPRODUCT((Data!R2C1:R2000C1=Interface!R18C6)*(Data!R2C3:R2000C3=Interface!R[0]C6)*(Data!R2C4:R2000C4=Data!R1C8))"
 
Range("L19:L" & nr_corr).FormulaR1C1 = "=SUMPRODUCT((Data!R2C1:R2000C1=Interface!R18C6)*(Data!R2C3:R2000C3=Interface!R[0]C6)*(Data!R2C4:R2000C4=Data!R1C8)*(Data!R2C7:R2000C7))/SUMPRODUCT((Data!R2C1:R2000C1=Interface!R18C6)*(Data!R2C3:R2000C3=Interface!R[0]C6)*(Data!R2C4:R2000C4=Data!R1C8))"
 
 
     'Filteren benamingen
    Range("D18:D1149").Replace What:=" Equity", Replacement:="", LookAt:=xlPart, _
    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False
 
    Range("D18:D1149").Replace What:="Equity", Replacement:="", LookAt:=xlPart, _
    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False
 
    Range("D18:D1149").Replace What:=" EQUITY", Replacement:="", LookAt:=xlPart, _
    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False
 
    Range("D18:D1149").Replace What:="EQUITY", Replacement:="", LookAt:=xlPart, _
    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False
 
    Range("D18:D1149").Replace What:=" equity", Replacement:="", LookAt:=xlPart, _
    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False
 
    Range("D18:D1149").Replace What:="equity", Replacement:="", LookAt:=xlPart, _
    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False
 
    Range("D18:D1149").Replace What:="  ", Replacement:=" ", LookAt:=xlPart, _
    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False
 
    Range("D18:D1149").Replace What:="   ", Replacement:=" ", LookAt:=xlPart, _
    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False
 
    Range("D18:D1149").Replace What:="    ", Replacement:=" ", LookAt:=xlPart, _
    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False
 
    Range("D18:D1149").Replace What:="     ", Replacement:=" ", LookAt:=xlPart, _
    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False
 
    Range("D18:D1149").Replace What:="      ", Replacement:=" ", LookAt:=xlPart, _
    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False
 
    Range("D18:D1149").Replace What:="       ", Replacement:=" ", LookAt:=xlPart, _
    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False
 
 
'##########
 
'default variabelen tijdsduur
Range("G3").Select
ActiveCell.FormulaR1C1 = "5"
Range("G4").Select
ActiveCell.FormulaR1C1 = "0"
 
Range("G5").Select
ActiveCell.FormulaR1C1 = "0"
Range("A1").Select
'Default variabel correlatie
Range("D8").Select
ActiveCell.FormulaR1C1 = "0.60"
 
'recalculate
    Application.Calculation = xlAutomatic
 
'replace
    Range("J18:J1000").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("L18:L1000").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
 
    Application.CutCopyMode = False
 
'Velden zonder weergave geven - aan
    Range("J18:J1000").Replace What:="#DIV/0!", Replacement:="-", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False
 
    Range("L18:L1000").Replace What:="#DIV/0!", Replacement:="-", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False
 
    Range("A1").Select
     '### Stop Timer
    sngEnd = Timer
    sngElapsed = Format(sngEnd - sngStart, "Fixed")
 
     'Tijdsmelding aantal seconden proces snelheid
     Range("F8").Value = sngElapsed & " seconden"
 
    With Application
 
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
    End With
 
End Sub
' Tickerlijst wissen
Private Sub CommandButton2_Click()
Range("B18").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.ClearContents
 
End Sub
' Koppelen afhankelijk fonds uit drop down menu met onafhankelijk fonds, weergeven in Bloomberg
Private Sub CommandButton3_Click()
    blp = DDEInitiate("winblp", "bbk")
a = Range("D18").Value
k = Range("C16").Value
     Call DDEExecute(blp, "<BLP-1>" & "<CANCEL>" & a & "<EQUITY>" & "       " & k & "<EQUITY>" & " " & "HS" & "<GO>")
     'Call DDETerminate(blp)
 
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
End Sub

We hope somebody is willing to help us improving our code!

Many thanks,

Amateur1902

 

[Richard Schollar]

Hi

That's a lot of code and not very much description, so it will be very difficult for anyone to suggest wholesale improvements. You have Selects in the code which are probably unnecessary and you are writing what I presume is many formulas to the sheet which will slow it down. Also at the start, you are processing a range and writing values to an array which will be somewhat slower than writing the entire range to an array and then processing the array in memory.

Other than that, there's simply too much code there for anyone to spend too long on it. Try analysing what it is your code is doing and then ask advice on particular chunks of it. For me or anyone else to refactor your code in its entirety would take a long time, something which I simply don't have time for.

 

[amateur1902]

You are right Richard, the code is to long, sorry for that!

Thank you for your answer! The formules can't be removed, when we do that, we have to put the formules in Excel cels. The system must be idiot proof and they must not be capable to delete the formules. If we protect the worksheets we get problems in VBA.

The part about the array:

Also at the start, you are processing a range and writing values to an array which will be somewhat slower than writing the entire range to an array and then processing the array in memory.

I don't understand yet, but we will take a look at it.

The .Select part is something that we have heard before, we changed that then and that worked well. But this raises another question: for wich name we can replace the .Select best?

Thank you for your cooperation!

 

[JimmyDodger]

What he's trying to say is that you don't need to sect a cell or range before you do something to it.

So you could replace

   Range("N15").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

with

   Range("N15").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

It only makes a small diference each time, but if you do it enough, or if you are doing it a loop, it can make a lot of difference.

 

[amateur1902]

Thank you very much Jimmy! I will remove all the .Select parts and I'm sure that this will improve the speed. It's clear now, I do not have to replace the .Select for some other term.

Great tips gentlemen, many thanks!