Speeding up code and screen flickering using screenupdating - vba

Question

I have created a macro where I download data into Excel from a software database through an array formula. The scope of the macro is to input a start date and the data is written to individual Excel files and then saved away.
Unfortunately the macro is very slow although I am using the usual code lines to speed up the macro.
Another problem is that the array formula constantly expands the UsedRange with empty lines and thus the file gets bigger and bigger. To counteract this, I delete the empty lines within a For Next loop. Last but not least I still have screen flickering. My guess is the use of DoEvents but I need it for the update of the array formula.Otherwise the code will continue without having the data downloaded.
Below is my code:
Sub Update()
Dim wbTarget As Workbook
Dim objWsInput As Worksheet, objWsMakro As Worksheet, objWsDerivative, objWsFile
Dim Inbox1 As Variant
Dim strFormula As String, strFilename As String, strDate As String
Dim lngDate As Long
Dim dDay As Date
Set objWsInput = ThisWorkbook.Worksheets("INPUT")
'Input start date
Inbox1 = InputBox("Geben Sie bitte ein Start-Datum ein!", Default:=Format(Date, "DD.MM.YYYY"))
Call EventsOff
For dDay = DateSerial(Year(Inbox1), Month(Inbox1), Day(Inbox1)) To DateSerial(Year(Now), Month(Now), Day(Now))
If Weekday(dDay) <> 1 And Weekday(dDay) <> 7 Then
'Convert date into DateValue & string
strDate = Format(dDay, "YYYYMMDD")
lngDate = DateValue(dDay)
'Delete contents
With objWsInput
.Activate
.UsedRange.ClearContents
'Set array formula for QPLIX
strFormula = "=DisplayAllocationWithPreset(""5a9eb7ae2c94dee7a0d0fd5c"", ""5b06a1832c94de73b4194ccd"", " & lngDate & ")"
.Range("A1").FormulaArray = strFormula
'Wait until refresh is done
Do
DoEvents
Loop While Not Application.CalculationState = xlDone
'Copy paste
.Range("A1").CurrentRegion.Copy
.Range("A1").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
'Call last row and delete depth 0 with number format
i = 2
Call LastRow
For i = CountRow To 2 Step -1
If .Cells(i, 1) = 0 Then .Rows(i).Delete
Next i
Call NumberFormat
'Set file name
strFilename = "Y:\Risikomanagement\Mandate Positions\QPLIX_Mandate_Positions_" & strDate & ".xlsx"
'Open file
Set wbTarget = Workbooks.Add
Set objWsFile = wbTarget.Worksheets(1)
'Copy data into new file
.Range("C1:J" & .Range("A1").CurrentRegion.Rows.Count).Copy Destination:=objWsFile.Range("A1")
'Save file
wbTarget.SaveAs Filename:=strFilename
wbTarget.Close
Call DeleteBlankRows
End With
End If
Next dDay
'Save Workbook
ActiveWorkbook.Save
Call EventsOn
MsgBox "Upload Files erstellt!", vbInformation, "Hinweis"
End Sub
The support functions are as followed:
Public Sub EventsOff()
'Events ausschalten
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With
End Sub
Public Sub EventsOn()
'Events anschalten
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
.DisplayAlerts = True
End With
End Sub
To complete my code here are the parts for deleting empty rows & formatting the numbers:
Sub DeleteBlankRows()
Dim MyRange As Range
Dim iCounter As Long
Set MyRange = ActiveSheet.UsedRange
For iCounter = MyRange.Rows.Count To 1 Step -1
'Step 4: If entire row is empty then delete it.
If Application.CountA(Rows(iCounter).EntireRow) = 0 Then
Rows(iCounter).Delete
End If
Next iCounter
End Sub
Sub NumberFormat()
Dim r As Range
For Each r In ActiveSheet.UsedRange.SpecialCells(xlCellTypeConstants)
If IsNumeric(r) Then
r.Value = CDec(r.Value)
r.NumberFormat = "#,##0.00"
End If
Next r
End Sub
Any help is appreciated.Thank you in advance.
Rgds

Answer 1

It seems that DoEvents disables the usual speed up procedures like:
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
I changed my code including the support function Call Events Off directly after DoEvents loop and the flickering disappeared. The whole process was also much faster.