Data acquisition from the web

[bknight]

Other than I still received an invalid object defined error in a watch, the procedure worked correctly
Thanks Hans and Rudi for your time, patience and help.

[bknight]

I have to resurrect this one for an error that occurred last night. In my code I'm looking for a strDate that on my sheets is 12/02/2019 but the date on the data from the web is 12/2/2019 so the Find instruction indicates the date can't be found, so the data is added at the end of the dates. One of the reasons that I never copied the date from the web data to mine as I really don't like to look at 12/2/2019. Of course it means the exact same date, just me.
Anyway what would anyone suggest a fix for the Find?
Maybe that is the reason Rudi did a CDate on the strDate?

[HansV]

What if you change

Code: Select all

strDate = Format(Worksheets("VixData").Range("B" & LastRow).Value, "mm/dd/yyyy")

to

Code: Select all

strDate = Format(Worksheets("VixData").Range("B" & LastRow).Value, "m/d/yyyy")

[bknight]

In similar method why not reduce "yyyy" to "yy"?

[HansV]

You mentioned that the data from the web look like 12/2/2019 i.e. with a 4-digit year.
But it won't hurt to try...

[bknight]

Well I seem to be stumbling at opening the web site
http://www.cboe.com/publish/scheduledta ... urrent.csv" onclick="window.open(this.href);return false;
"The resource cannot be displayed because the file extension is not being accepted by your browser."
I still don't know what/where settings that affect the extensions that are allowed. This does not happen all the time, but persistent this morning.

[HansV]

You mentioned this before; I have no idea what causes it.

[bknight]

After trying about X times, it finally opened and the changes you suggested worked leaving "yyyy"
Thanks

[HansV]

Phew!

[Rudi]

Phew x2

[bknight]

I need one more bit of help on this and It could be directed toward Hans or Rudi. In the code

Code: Select all

Sub RefreshPutCallRatio()
Dim shSource As Worksheet, shDestination As Worksheet
Dim rgF As Range
Dim strDate As String
Dim lRow As Long
    Set shSource = Sheets("Data")
    Set shDestination = Sheets("PutCall Ratio")
    '==========================================================================================
    'NOTE: Make sure to disable background refresh in the connection properties for the tables.
    'Access the connections dialog and disable the 'Enable background refresh' option.
    'shSource.Cells(1).QueryTable.Refresh BackgroundQuery:=False
    Worksheets("Data").Range("A2").QueryTable.Refresh BackgroundQuery:=False
    'shSource.Range("Connection").QueryTable.Refresh BackgroundQuery:=False
    'ActiveWorkbook.Connections("Connection").Refresh '< Use this for Excel2007 and higher
    '==========================================================================================
    With shDestination

        strDate = Format(Worksheets("Data").Range("H2").Value, "m/d/yyyy")
        On Error Resume Next
        Set rgF = .Columns(1).Cells.Find(What:=CDate(strDate), After:=Range("A1"), LookIn:=xlFormulas, _
            LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
        On Error GoTo 0
        
        If rgF Is Nothing Then
            MsgBox "Date cannot be found on PutCall Ratio sheet! Record will be added to the end of the table!", vbExclamation
            lRow = .Cells(1).CurrentRegion.Rows.Count + 1
            .Cells(lRow, "A").Value = shSource.Range("H2").Value
            .Cells(lRow, "B").Value = shSource.Range("H3").Value
            .Cells(lRow, "C").Value = shSource.Range("H4").Value
            .Cells(lRow, "D").Value = shSource.Range("H5").Value
            .Cells(lRow, "E").Value = shSource.Range("H6").Value
            If (.Cells(lRow - 1, "B")) - (.Cells(lRow - 1, "C")) < -500 And _
               (.Cells(lRow, "B")) - (.Cells(lRow, "C")) > -500 Then _
               .Range(.Cells(lRow, "B"), .Cells(lRow, "C")).Interior.Color = vbGreen
            .Cells(lRow, "F").Value = "=(R[-1]C*R3C9)+(RC[-1]*R2C9)"
            .Cells(lRow, "G").Value = "=(R[-1]C*R7C9)+(RC[-2]*R6C9)"
            .Cells(lRow, "H").Value = "=RC[-2]/RC[-1]"
            .Cells(lRow, "K").Value = "=AVERAGE(R[-8]C[-6]:R[-1]C[-6])"
            .Cells(lRow, "L").Value = "=AVERAGE(R[-20]C[-7]:R[-1]C[-7])"
            Application.Goto .Cells(lRow, 1), True
        ElseIf Not rgF Is Nothing Then
            lRow = rgF.Row
            .Cells(lRow, "B").Value = shSource.Range("H3").Value
            .Cells(lRow, "C").Value = shSource.Range("H4").Value
            .Cells(lRow, "D").Value = shSource.Range("H5").Value
            .Cells(lRow, "E").Value = shSource.Range("H6").Value
            'If (.Cells(lRow - 1, "B")) - (.Cells(lRow - 1, "C")) < -500 And _
               '(.Cells(lRow, "B")) - (.Cells(lRow, "C")) > -500 Then _
               '.Range(.Cells(lRow, "B"), .Cells(lRow, "C")).Interior.Color = vbGreen
            .Cells(lRow, "F").Value = "=(R[-1]C*R3C9)+(RC[-1]*R2C9)"
            .Cells(lRow, "G").Value = "=(R[-1]C*R7C9)+(RC[-2]*R6C9)"
            .Cells(lRow, "H").Value = "=RC[-2]/RC[-1]"
            .Cells(lRow, "K").Value = "=AVERAGE(R[-8]C[-6]:R[-1]C[-6])"
            .Cells(lRow, "L").Value = "=AVERAGE(R[-20]C[-7]:R[-1]C[-7])"
            Application.Goto .Cells(lRow + 1, 2), True
        End If

    End With

End Sub

When the code finishes the selected cell is correct, but not how I would like to view the results. Namely all I see is blank cells below and ight of the selected cells. What I would like to see is several full rows of data above the selected cell along with the dates. See the two images. How could this be coded?

[HansV]

Change

Code: Select all

            Application.Goto .Cells(lRow + 1, 2), True

to

Code: Select all

            Application.Goto .Cells(lRow - 12, 2), True
            .Cells(lRow + 1, 2).Select

[bknight]

Here are my attempts:

Code: Select all

    Cells(lRow + 1, 2).Select
    'Range(Cells(Row + 1, 2), Cells(lRow + 1, 2)).Select
    'Selection.xlUp.Select
    'Selection.xlLeft.Select
    'Selection.xlDown.Select
    'Selection.xlRight.Select
    'GoSub CopyCellsFormulas

The select didn't change the display and the Up, Down, Left, Right errored in object(?) doesn't upport that command.

[HansV]

xlUp, xlDown, xlToLeft and xlToRight can be used in the End method of a range, e.g. ActiveCell.End(xlUp).Select.
This is the equivalent of pressing the End key, then an arrow key.

xlLeft and xlRight can be used to specify the horizontal alignment of the text in a cell.

Did you try my suggestion?

[bknight]

Not yet although my Cells(lRow + 1, 2).Select was a close proxy. However the command might be
Application.Goto .Cells(lRow - 12, 1), True
.Cells(lRow + 1, 2).Select

I'll have to try that on Monday, If I am able to run the part where it still periodically give the error message that the object can't be down loaded. I searched and came up with this MS answer, but it didn't work yesterday or this morning. I manually had to enter and copy the data. Grrrrrrrrrrrrrr
https://blogs.technet.microsoft.com/the ... rom-excel/" onclick="window.open(this.href);return false;

[bknight]

I just stepped through the code bypassing many of the step that would have ended up copying incorrect formulas since the current day data has been finished, but your suggestion seemed to worked.
Thanks again.

[bknight]

Well the last "fix" came from https://docs.microsoft.com/en-us/office ... -hyperlink" onclick="window.open(this.href);return false;
I created a "ForceShellExecute" DWORD in the Computer\HKEY_CURRENT_USER\Software\Microsoft\Office\12.0\ForceShellExecute (my version) and set it to one.
However I did have a minor hiccup in the overall execution, one that had not occurred before. It took a long time to complete the part Rudi helped me with so I opened the site https://markets.cboe.com/us/options/mar ... ics/daily/" onclick="window.open(this.href);return false; with no problems and then came back to excel to find an error message, somethin like there was no good certificate available(?) "Do you wish to continue?" I selected yes and the program executed without any further errors.

Is there somewhere inside excel that I can add this address so a certificate will not be checked or necessary?

[HansV]

Does Bypassing a website's Security Certificate warning using VBA help?

[bknight]

This is the code Rudi developed with a few changes that you and I discussed

Code: Select all

Sub RefreshPutCallRatio()
Dim shSource As Worksheet, shDestination As Worksheet
Dim rgF As Range
Dim strDate As String
Dim lRow As Long
    Set shSource = Sheets("Data")
    Set shDestination = Sheets("PutCall Ratio")
    '==========================================================================================
    'NOTE: Make sure to disable background refresh in the connection properties for the tables.
    'Access the connections dialog and disable the 'Enable background refresh' option.
    'shSource.Cells(1).QueryTable.Refresh BackgroundQuery:=False
    Worksheets("Data").Range("A2").QueryTable.Refresh BackgroundQuery:=False
    'shSource.Range("Connection").QueryTable.Refresh BackgroundQuery:=False
    'ActiveWorkbook.Connections("Connection").Refresh '< Use this for Excel2007 and higher
    '==========================================================================================
    With shDestination

        strDate = Format(Worksheets("Data").Range("H2").Value, "m/d/yyyy")
        On Error Resume Next
        Set rgF = .Columns(1).Cells.Find(What:=CDate(strDate), After:=Range("A1"), LookIn:=xlFormulas, _
            LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
        On Error GoTo 0
        
        If rgF Is Nothing Then
            MsgBox "Date cannot be found on PutCall Ratio sheet! Record will be added to the end of the table!", vbExclamation
            lRow = .Cells(1).CurrentRegion.Rows.Count + 1
            .Cells(lRow, "A").Value = shSource.Range("H2").Value
            .Cells(lRow, "B").Value = shSource.Range("H3").Value
            .Cells(lRow, "C").Value = shSource.Range("H4").Value
            .Cells(lRow, "D").Value = shSource.Range("H5").Value
            .Cells(lRow, "E").Value = shSource.Range("H6").Value
            If (.Cells(lRow - 1, "B")) - (.Cells(lRow - 1, "C")) < -500 And _
               (.Cells(lRow, "B")) - (.Cells(lRow, "C")) > -500 Then _
               .Range(.Cells(lRow, "B"), .Cells(lRow, "C")).Interior.Color = vbGreen
            .Cells(lRow, "F").Value = "=(R[-1]C*R3C9)+(RC[-1]*R2C9)"
            .Cells(lRow, "G").Value = "=(R[-1]C*R7C9)+(RC[-2]*R6C9)"
            .Cells(lRow, "H").Value = "=RC[-2]/RC[-1]"
            .Cells(lRow, "K").Value = "=AVERAGE(R[-8]C[-6]:R[-1]C[-6])"
            .Cells(lRow, "L").Value = "=AVERAGE(R[-20]C[-7]:R[-1]C[-7])"
            Application.Goto .Cells(lRow, 1), True
        ElseIf Not rgF Is Nothing Then
            lRow = rgF.Row
            .Cells(lRow, "B").Value = shSource.Range("H3").Value
            .Cells(lRow, "C").Value = shSource.Range("H4").Value
            .Cells(lRow, "D").Value = shSource.Range("H5").Value
            .Cells(lRow, "E").Value = shSource.Range("H6").Value
            'If (.Cells(lRow - 1, "B")) - (.Cells(lRow - 1, "C")) < -500 And _
               '(.Cells(lRow, "B")) - (.Cells(lRow, "C")) > -500 Then _
               '.Range(.Cells(lRow, "B"), .Cells(lRow, "C")).Interior.Color = vbGreen
            .Cells(lRow, "F").Value = "=(R[-1]C*R3C9)+(RC[-1]*R2C9)"
            .Cells(lRow, "G").Value = "=(R[-1]C*R7C9)+(RC[-2]*R6C9)"
            .Cells(lRow, "H").Value = "=RC[-2]/RC[-1]"
            .Cells(lRow, "K").Value = "=AVERAGE(R[-8]C[-6]:R[-1]C[-6])"
            .Cells(lRow, "L").Value = "=AVERAGE(R[-20]C[-7]:R[-1]C[-7])"
            Application.Goto .Cells(lRow - 12, 1), True
        End If

As you can see he put in an on error statement after setting strDate, but this is subsequent to opening the website. There is private sub on a Data tab

Code: Select all

Private Sub GetDataWeb()
    Application.CutCopyMode = False
    With ActiveSheet.QueryTables.Add(Connection:= _
        "URL;https://markets.cboe.com/us/options/market_statistics/daily", Destination _
        :=Range("$A$2"))
        '.CommandType = 0
        .Name = "daily"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = xlEntirePage
        .WebFormatting = xlWebFormattingNone
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
    End With
    Selection.QueryTable.Refresh BackgroundQuery:=False
End Sub

This would be I guess the place to put on error resume next, so maybe

Code: Select all

On Error Resume Next
With ActiveSheet.QueryTables.Add(Connection:= _
        "URL;https://markets.cboe.com/us/options/market_statistics/daily", Destination _
        :=Range("$A$2"))
On Error GoTo 0

I'm not sure this is how coding should be added to bypass the warning.
Note all the time I have used all the code since CBOE change the format of data presentation on PutCall, this error has only occurred last night. Not to say it won' do it again tonight or next month.

[HansV]

You could also try

Code: Select all

    Application.DisplayAlerts = False
    With ActiveSheet.QueryTables.Add(Connection:= _
        "URL;https://markets.cboe.com/us/options/market_statistics/daily", Destination _
        :=Range("$A$2"))
            …
    End With
    Application.DisplayAlerts = False