Screen flickering while macros running despite disabled screen updating.

[dilshod_k]

Hello everyone,

I would be grateful for any help with screen flickering. The macros download list of stocks historical price data and inserts them in the corresponding to each stock CSV file in the folder C:\VBA\. Screen updates are disabled. I can't figure out what else could be done. Thanks in advance for any help.

Dim cell As Range
Dim myfile As String
Dim directory As String
Dim FileExt As String

Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayStatusBar = False
Application.DisplayAlerts = False
On Error Resume Next

    For Each cell In Range("K1:K100") 'Column with the list of stocks
        If cell.Value <> "" Then
            Worksheets("Sheet1").Range("S5").Value = cell.Value 'Cell S5 contains current stock symbol
                Call GetYahooDataFromJSON 'This macros download historical price data
                    directory = "C:\VBA\" 'Directory where all corresponding to stocks CSV files stored
                    FileExt = ".csv" 'File extensions
                    'Cell S5 = value = stock symbol
                    myfile = directory & Cells(5, 19).Value & FileExt 'Path to the current CSV file to be opened
                    Application.Workbooks.Open Filename:=myfile
                    ActiveSheet.Range("B2").Insert Shift:=xlShiftDown 'Destination range in the opened CSV file
                    ActiveWorkbook.Close True   'This line causes troubles if corresponding to stock CSV file does not exist in the folder, it closes workbook with macros.
        End If
    Next cell

Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayStatusBar = True
Application.DisplayAlerts = True
Application.CutCopyMode = False

End Sub

 

[RoryA]

Does the code for GetYahooDataFromJSON do anything to Screenupdating?

 

[dilshod_k]

Does the code for GetYahooDataFromJSON do anything to Screenupdating?

I'm not sure. I tried to insert instructions as they follow below in each functions of the GetYahoo... code and in the sub itself, it did not help. I can attach the whole workbook if it helps but I can't find if this option available here. Thank you in advance for your help.

Application.ScreenUpdating = False

Application.EnableEvents = False

Application.DisplayStatusBar = False

Application.DisplayAlerts = False

 

[RoryA]

You can't attach files here, I'm afraid. Can you post the code for GetYahooDataFromJSON?

 

[dilshod_k]

You can't attach files here, I'm afraid. Can you post the code for GetYahooDataFromJSON?

Sorry for the delay with answer. Had to go out. Sure I can post it.

Option Explicit

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'   Fetches historical stock prices from Yahoo using the https://query1.finance.yahoo.com/v7/finance/chart/ interface
'   Written by Andrew MacLean Nov 20th 2017 Version 1.0d updates at http://www.signalsolver.com/EmulateURL.
'   Questions, Comments, Requests?, please contact support@algorithmscience.com
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub GetYahooDataFromJSON()

Dim DesiredFields As Variant, NameOfStock As String
Dim RangeField As String, RangeUnit As String, s As Variant, IntervalField As String, DateOrder As Integer
Dim DateOffset As Double, ErrorMsg As String, FilterFilterOutRows As Boolean
Dim BeginDate As Date, EndDate As Date

Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayStatusBar = False
Application.DisplayAlerts = False


With ActiveSheet

'READ THE STOCK SYMBOL:
NameOfStock = .Range("StockSymbol")

'READ THE RANGE
RangeField = CStr(.Range("Range"))

'READ AND TRANSLATE THE RANGE UNIT
s = CStr(.Range("RangeUnit"))
Select Case s:
    Case "Maximum": RangeUnit = "max": RangeField = ""
    Case "YTD": RangeUnit = "ytd": RangeField = ""
    Case "Years": RangeUnit = "y"
    Case "Months": RangeUnit = "mo"
    Case "Weeks": RangeUnit = "wk"
    Case "Days": RangeUnit = "d"
    Case "Hours": RangeUnit = "h"
    Case "Minutes": RangeUnit = "m"
End Select
RangeField = RangeField & RangeUnit

'READ AND TRANSLATE THE INTERVAL FIELD
s = CStr(.Range("Interval"))
Select Case s:
    Case "1 minute": IntervalField = "1m"
    Case "2 minutes": IntervalField = "2m"
    Case "5 minutes": IntervalField = "5m"
    Case "10 minutes": IntervalField = "10m"
    Case "15 minutes": IntervalField = "15m"
    Case "30 minutes": IntervalField = "30m"
    Case "1 hour": IntervalField = "1h"
    Case "2 hour": IntervalField = "2h"
    Case "4 hour": IntervalField = "4h"
    Case "6 hour": IntervalField = "6h"
    Case "1 day": IntervalField = "1d"
    Case "1 week": IntervalField = "1wk"
    Case "1 month": IntervalField = "1mo"
    Case "3 months": IntervalField = "3mo"
End Select

'READ THE DATE ORDER
s = CStr(.Range("DateOrder"))
If s = "Ascending" Then DateOrder = xlAscending Else DateOrder = xlDescending

'READ THE TIME OFFSET:
DateOffset = CDbl(.Range("TimeOffset"))

'FILTER BAD ROWS?
If (.Range("FilterBadRows")) = "Yes" Then FilterFilterOutRows = True Else FilterFilterOutRows = False

'START AND END DATE:
BeginDate = .Range("StartingDate"): EndDate = .Range("EndingDate")

'SINCE WE HAVE A START DATE AND END DATE, THE RANGE CAN GET A BIT COMPLICATED, WE WILL ADDRESS THAT IN A LATER RELEASE
'FOR NOW JUST MAKE SURE YOUR RANGE COVERS THE START AND END DATE

'YOU CAN ADD OR REMOVE AS MANY JSON FIELDS YOU LIKE HERE, OR RE-ORDER THEM:

DesiredFields = Array("timestamp", "open", "high", "low", "close", "volume")
'1.0d YOU CAN ASK FOR adjclose IF IntervalField IS 1d, 1w, 1mo or 3mo.
If Right(IntervalField, 1) <> "m" And Right(IntervalField, 1) <> "h" Then
    DesiredFields = Array("timestamp", "open", "high", "low", "close", "adjclose", "volume")
End If

'CHANGE THE BUTTON COLOR AND TEXT:
.Shapes("Shape1").Fill.ForeColor.RGB = RGB(0, 200, 0)
.Shapes("Shape1").TextFrame.Characters.Text = "Asking for data..."
Application.ScreenUpdating = True 'JUST ENSURES UPDATE OF THE BUTTON

'GET THE DATA. IF YOU WANT THE DATA IN A DIFFERENT PLACE, CHANGE THE .Range("TableOrigin") TO SOMETHING ELSE E.G. Sheet2.Range("A1")
ErrorMsg = GetYahooRequest(.Range("TableOrigin"), DesiredFields, NameOfStock, RangeField, _
    IntervalField, DateOrder, DateOffset, FilterFilterOutRows, BeginDate, EndDate)
If ErrorMsg <> "" Then MsgBox (ErrorMsg)

'CHANGE THE BUTTON BACK
.Shapes("Shape1").Fill.ForeColor.RGB = RGB(200, 0, 0)
.Shapes("Shape1").TextFrame.Characters.Text = "Click to get historic data"
Application.ScreenUpdating = True 'JUST ENSURES UPDATE OF THE BUTTON

End With 'ActiveSheet
 
 Range("A2", Range("A2").End(xlDown).End(xlToRight)).Copy
 
End Sub

Function GetYahooRequest( _
    DestinationRange As Range, _
    FieldsToExtract As Variant, _
    StockSymbol As String, _
    RangePart As String, _
    IntervalPart As String, _
    Optional DateOrder As Integer = xlDescending, _
    Optional TOffset As Double = 0, _
    Optional FilterBadPrices As Boolean = False, _
    Optional StartingDate As Date = 0, _
    Optional EndingDate As Date = 0 _
) As String

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
'FETCHES HISTORICAL STOCK PRICES FROM YAHOO FINANCE USING THE query1.finance.yahoo.com/v7/finance/chart INTERFACE
'WRITES THE PARSED JSON DATA TO A WORKSHEET AFTER CLEARING THE CONTENTS OF THE REGION
'RETURNS AN EMPTY STRING IF NO ERROR DETECTED, OTHERWISE RETURNS A POSSIBLY MEANINGFUL ERROR MESSAGE
'
'ARGUMENTS:
'DestinationRange As Range, THE TOP LEFTMOST CELL OF THE TABLE WHERE THE DATA SHOULD BE PUT E.G. Sheet1.Range("A20")
'FieldsToExtract As Variant, AN ARRAY OF JSON KEYS E.G. = Array("timestamp", "open", "high", "low", "close", "volume")
'StockSymbol As String: THE STOCK SYMBOL, E.G. AAPL, BP.L, ^GDAXI
'RangePart As String: THE OVERALL TIME RANGE OF THE DATA: CAN BE max, ytd, Xy, Xm, Xd, Xh, Xm WHERE X IS AN INTEGER, E.G. "50d"
'IntervalPart As String: THE TIME INTERVAL OF EACH DATA BAR: 1m, 2m, 5m, 15m, 1h, 1d, 1mo, 3mo
'OPTIONAL:
'DateOrder As Integer: CAN ONLY BE xlAscending OR xlDescending. DEFAULT IS DESCENDING
'TOffest As Double: A NUMBER REPRESENTING A TIME OFFSET IN HOURS. DATES WILL BE OFFSET BY THIS AMOUNT FROM GMT. CAN BE NEGATIVE, DEFAULT 0
'FilterBadPrices As Boolean: IF True, REMOVES ALL LINES WITH "nulls" OR ZEROS IN THE PRICES. DEFAULT IS False
'StartingDate as Date: ANY ROW WITH A TIMESTAMP + TOffset (i.e LOCAL TIME) BEFORE THIS DATE WILL BE FILTERED OUT. ZERO STOPS FILTERING
'EndingDate as Date: ANY ROW WITH A TIMESTAMP + TOffset (i.e LOCAL TIME) AFTER THIS DATE WILL BE FILTERED OUT. ZERO STOPS FILTERING
'
'   WRITTEN BY Andrew MacLean Oct 9th 2017 Version 1.0d updates at http://www.signalsolver.com.
'   Questions, Comments, Requests?, please contact support@algorithmscience.com
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayStatusBar = False
Application.DisplayAlerts = False


On Error GoTo ErrorHandler

Dim strUrl As String
strUrl = "https://query1.finance.yahoo.com/v7/finance/chart/" & StockSymbol & "?range=" & RangePart & "&interval=" & IntervalPart & "&indicators=quote&includeTimestamps=true"
'IF THE COMPILER DOESN'T RECOGNIZE WinHttp, SIMPLY MAKE SURE THAT "Microsoft WinHTTP Services" ARE ENABLED UNDER VBA TOOLS->REFERENCES

Dim objRequest As WinHttp.WinHttpRequest
Dim strResponse As String
Dim N() As String
Dim RawOutputArray() As Variant, FilteredOutputArray() As Variant
Dim FilterOutRows() As Variant, FilteredRowCount As Integer: FilteredRowCount = 0
Dim FieldName As Variant
Dim xRow As Integer: xRow = 0
Dim RowCount As Integer, ColumnCount As Integer
Dim xColumn As Integer
Dim StrX As String
Dim ParseError As String
Dim DecSeparator As String: DecSeparator = Application.International(xlDecimalSeparator)
Dim FilterOutput As Boolean
    
'FILTER LOGIC:
If FilterBadPrices = True Or StartingDate <> 0 Or EndingDate <> 0 Then FilterOutput = True

    Set objRequest = New WinHttp.WinHttpRequest
    
    With objRequest
        .Open "GET", strUrl, True
        .setRequestHeader "Content-Type", "application/x-www-form-urlencoded; charset=UTF-8"
        .send
        .waitForResponse
        strResponse = .responseText
    End With
    
    'UNCOMMENT THIS LINE IF YOU WOULD LIKE TO EXAMINE THE JSON CODE (SET THE DESTINATION RANGE):
    'N = Split(strResponse, ","): ActiveSheet.Range("J1").Resize(UBound(N) + 1) = WorksheetFunction.Transpose(N)
    
    'BEST TO CLEAR THE REGION BEFORE WRITING TO IT
    DestinationRange.CurrentRegion.ClearContents
    
    
    For Each FieldName In FieldsToExtract
        'LOOK FOR DATA AND WRITE IT TO HoldArray String ARRAY IF WE FIND IT:
        Dim HoldArray() As String
        ParseError = ParseField(strResponse, CStr(FieldName), HoldArray)
        If ParseError <> "" Then GoTo ErrorHandler
        
        'RESIZE A VARIANT ARRAY TO HOLD THE RESULT.
        'THIS GIVES US BETTER CONTROL OF THE STRING CONVERSIONS
        If xColumn = 0 Then
            RowCount = UBound(HoldArray) + 1
            ColumnCount = UBound(FieldsToExtract) + 1
            ReDim RawOutputArray(RowCount, ColumnCount - 1)
            'WE WILL LATER OPTIONALLY FILTER OUT ROWS INTO THE FINAL OUTPUT ARRAY, THIS ARRAY TRACKS THEM
            ReDim FilterOutRows(RowCount)
            ReDim DateFilter(RowCount)
            '1.0c INITIALIZE FilterOutRows
            For xRow = 1 To RowCount: FilterOutRows(xRow) = False: Next xRow
        End If
        
        'THIS WRITES THE HEADER FOR THE FIELD OF INTEREST:
        RawOutputArray(0, xColumn) = StrConv(FieldName, vbProperCase)
        
        'CONVERT EACH STRING INTO A VARIANT IN THE RawOutputArray:
        For xRow = 1 To RowCount
        
        StrX = HoldArray(xRow - 1)
            Select Case FieldName
                Case "timestamp":
                Dim LocalDate As Date
                    If IsNumeric(StrX) Then 'CONVERT IT '1.0c ADDED
                        LocalDate = CDate(StrX / 86400) + 25569 + (TOffset / 24)
                        RawOutputArray(xRow, xColumn) = LocalDate
                        
                        '1.0c DATE FILTERING LOGIC
                        If StartingDate <> 0 Then If LocalDate <= StartingDate Then FilterOutRows(xRow) = True
                        If EndingDate <> 0 Then If LocalDate >= EndingDate Then FilterOutRows(xRow) = True
                        
                    Else 'NOT NUMERIC: LEAVE IT AS A STRING AND TAG IT TO BE FILTERED OUT
                        RawOutputArray(xRow, xColumn) = StrX
                        FilterOutRows(xRow) = True
                    End If
                    
                Case Else:
                    If IsNumeric(StrX) Then 'CONVERT IT
                        RawOutputArray(xRow, xColumn) = CDbl(Replace(StrX, ".", DecSeparator))
                        'TAG THE ROW IF ZERO PRICE:
                        If FieldName <> "volume" And RawOutputArray(xRow, xColumn) = 0 Then FilterOutRows(xRow) = True
                    Else 'NOT NUMERIC: LEAVE IT AS A STRING AND TAG IT TO FILTER OUT
                        RawOutputArray(xRow, xColumn) = (HoldArray(xRow - 1))
                        FilterOutRows(xRow) = True
                    End If
            
            End Select 'Fieldname
        Next xRow
        
        'MOVE ONTO THE NEXT COLUMN:
        xColumn = xColumn + 1
    Next
    
    'COUNT THE ROWS TO FILTER OUT:
    For xRow = 1 To RowCount
        If FilterOutRows(xRow) = True Then FilteredRowCount = FilteredRowCount + 1
    Next xRow
        
    'FOR THE CURIOUS:
    'If FilteredRowCount > 0 Then MsgBox FilteredRowCount & " Filtered Rows."
    
    'IF WE DON'T NEED TO FILTER THE RESULT, WRITE IT OUT TO THE SHEET:
    If FilterOutput = False Or FilteredRowCount = 0 Then
        
        DestinationRange.Resize(UBound(RawOutputArray, 1) + 1, UBound(RawOutputArray, 2) + 1) = RawOutputArray
    
    Else 'FilterOutput = True
    
        'RESIZE THE OUTPUT ARRAY TO EXCLUDE FILTERED ROWS:
        ReDim FilteredOutputArray(RowCount - FilteredRowCount, ColumnCount - 1)
        
        Dim xPointer As Integer: xPointer = 0
        
        'COPY THE DATA OVER BUT ONLY IF THE ROW IS GOOD:
        For xRow = 0 To RowCount 'HEADER IS ONE ROW
            If FilterOutRows(xRow) = False Then
                For xColumn = 0 To ColumnCount - 1
                            FilteredOutputArray(xPointer, xColumn) = RawOutputArray(xRow, xColumn)
                Next xColumn
                xPointer = xPointer + 1
            End If 'FilterOutRows...
        Next xRow
    
    'WRITE THE FILTERED RESULT TO THE SHEET:
    DestinationRange.Resize(UBound(FilteredOutputArray, 1) + 1, UBound(FilteredOutputArray, 2) + 1) = FilteredOutputArray
    
    End If 'FilterOutput
    
    'UNCOMMENT IF YOU WISH TO SEE THE FilterOutRow TAGS (SORT THE MAIN ARRAY ASCENDING)
    'DestinationRange.Offset(, 8).CurrentRegion.ClearContents
    'DestinationRange.Offset(, 8).Resize(UBound(RawOutputArray, 1) + 1, 1) = WorksheetFunction.Transpose(FilterOutRows)
    
    'YOU REVERSE THE DATE ORDER USING THIS LINE, IF YOU WROTE A HEADER SET xlYes OTHERWISE xlNo
    'key1 IS THE FIRST COLUMN, Date, USE DestinationRange.offset(,<number>) IF DATE IS IN ANOTHER COLUMN
    DestinationRange.CurrentRegion.Sort key1:=DestinationRange.Offset(, 0), order1:=DateOrder, Header:=xlYes

'PROBABLY NO ERROR IF YOU GOT HERE
GetYahooRequest = ""

Exit Function

ErrorHandler:
If xColumn = 0 Then
    If ParseError <> "" Then ParseError = ParseError & " Maybe its a bad symbol." Else ParseError = "No response. Maybe the network is unavailable."
End If

GetYahooRequest = ParseError
    
End Function

'ParseField IS CALLED FOR EACH JSON KEY, E.G. "open", "high", "low", "close", ETC.
Function ParseField(ByRef ResponseString As String, strKeyName As String, ByRef strHoldArray() As String) As String

Dim strDQ As String: strDQ = """" 'A SINGLE DOUBLE QUOTE. GO FIGURE.
Dim StartPos As Long, EndPos As Long, x As Long
Dim StringToFind As String
Dim CSVField As String

Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayStatusBar = False
Application.DisplayAlerts = False


'1.0d ADDED INITIAL """" SO adjclose and nonadjclose ARE NOT MISTAKEN FOR close
'THANKS TO Jonathan Garneau FOR SUGGESTING THIS FIX
StringToFind = """" & strKeyName & """" & ":["

'EXTRACT THE FIELD OF INTEREST: WE USE BINARY COMPARE AS IT IS FASTER, BUT REMEMBER, IT'S CASE SENSITIVE
'SOME KEY NAMES ARE REPEATED, THE LAST OCCURRENCE SEEMS TO GIVE THE DESIRED RESULTS, HENCE THE LOOP
Do
    StartPos = x
    x = InStr(StartPos + 1, ResponseString, StringToFind, vbBinaryCompare)
Loop While x <> 0

'CHECK THAT THE STRING WAS FOUND:
If StartPos = 0 Then
    ParseField = "Unable to find key " & strKeyName & " in JSON response."
    GoTo ErrorHandler
End If

'MOVE THE POINTER TO THE START OF THE DATA
StartPos = StartPos + Len(StringToFind)

'FIND THE END OF THE DATA
EndPos = InStr(StartPos, ResponseString, "]", vbBinaryCompare)
If EndPos = 0 Then
    ParseField = "Unable to find closing ] for " & strKeyName & " in JSON response."
    GoTo ErrorHandler
End If

'EXTRACT THE DATA AS A STRING:
CSVField = Mid(ResponseString, StartPos, EndPos - StartPos)

'REMOVE THE COMMAS AND PUT INTO THE HOLDING ARRAY:
strHoldArray = Split(CSVField, ",")

'IF YOU GET THIS FAR, PROBABLY NO ERRORS:
ParseField = ""

ErrorHandler:

End Function

 

[RoryA]

There's the issue - that code turns screenupdating back on. You'll need to turn it off again after calling that routine.

 

[dilshod_k]

There's the issue - that code turns screenupdating back on. You'll need to turn it off again after calling that routine.

Thanks a lot! Flickering is gone. You made my day. Appreciate it.