Проблемы с макросом My Web Query

Question

Проблемы с макросом My Web Query

Я написал макрос веб-запроса для импорта финансовых отчетов из Yahoo Finance на основе значения в ячейке A1. Последние несколько недель он работал бесперебойно, но внезапно больше не возвращает никаких данных (но не выдает ошибку). Если у кого-то есть идеи, я буду признателен за ваше руководство. Я разместил код ниже - спасибо!

Sub ThreeFinancialStatements()

   On Error GoTo Explanation



   Rows("2:1000").Select
    Selection.ClearContents
    Columns("B:AAT").Select


    Range(Selection, Selection.End(xlToRight)).Select
    Selection.ClearContents

    Dim inTicker As String
    inTicker = Range("A1")
    ActiveSheet.Name = UCase(inTicker)
    GetFinStats inTicker

    Exit Sub

Explanation:
   MsgBox "Please make sure you type a valid stock ticker symbol into cell A1 and are not trying to create a duplicate sheet." & _
   vbLf & " " & _
   vbLf & "Also, for companies with different classes of shares (e.g. Berkshire Hathaway), use a hyphen to designate the ticker symbol instead of a period (e.g. BRK-A)." & _
   vbLf & " " & _
   vbLf & "Please also note that not every company has three years of financial statements, so data may appear incomplete or missing for some companies.", _
  , "Error"

   Exit Sub
End Sub


Sub GetFinStats(inTicker As String)
'
' GetBalSheet Macro
'

'



    With ActiveSheet.QueryTables.Add(Connection:= _
        "URL;http://finance.yahoo.com/q/bs?s=" & inTicker & "+Balance+Sheet&annual", Destination:= _
        Range("$D$1"))
        .Name = "bs?s=PEP+Balance+Sheet&annual"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlOverwriteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = xlSpecifiedTables
        .WebFormatting = xlWebFormattingNone
        .WebTables = "9"
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
    End With
    With ActiveSheet.QueryTables.Add(Connection:= _
        "URL;http://finance.yahoo.com/q/is?s=" & inTicker & "+Income+Statement&annual", Destination _
        :=Range("$J$1"))
        .Name = "is?s=PEP+Income+Statement&annual"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlOverwriteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = xlSpecifiedTables
        .WebFormatting = xlWebFormattingNone
        .WebTables = "9"
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
    End With
    With ActiveSheet.QueryTables.Add(Connection:= _
        "URL;http://finance.yahoo.com/q/cf?s=" & inTicker & "+Cash+Flow&annual", Destination:= _
        Range("$P$1"))
        .Name = "cf?s=PEP+Cash+Flow&annual"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlOverwriteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = xlSpecifiedTables
        .WebFormatting = xlWebFormattingNone
        .WebTables = "9"
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
    End With

    Range("A3").Select
    ActiveCell.FormulaR1C1 = "Current Ratio"
    Range("A4").Select
    ActiveCell.FormulaR1C1 = "Quick Ratio"
    Range("A5").Select
    ActiveCell.FormulaR1C1 = "Cash Ratio"
    Range("A6").Select

    Range("A7").Select
    ActiveCell.FormulaR1C1 = "Revenue Growth Rate"
    Range("A9").Select
    Columns("A:A").ColumnWidth = 21.86
    ActiveCell.FormulaR1C1 = "ROA"
    Range("A10").Select
    ActiveCell.FormulaR1C1 = "ROE"
    Range("A11").Select
    ActiveCell.FormulaR1C1 = "ROIC"
    Range("B3").Select
    ActiveCell.Formula = "=F11/F28"
    Range("B4").Select
    ActiveCell.Formula = "=(F11-F8)/F28"
    Range("B5").Select
    ActiveCell.Formula = "=F5/F28"
    Range("B7").Select
    ActiveCell.Formula = "=(L2/N2)^(1/2)-1"
    Range("B9").Select
    ActiveCell.Formula = "=L35/SUM(F12:F18)"
    Range("B10").Select
    ActiveCell.Formula = "=L35/F47"
    Range("B11").Select
    ActiveCell.Formula = "=L35/(F47+SUM(F29:F33))"

    Range("B3").Select
    Selection.NumberFormat = "0.00"
    Range("B4").Select

    Selection.NumberFormat = "0.00"
    Range("B5").Select
    Selection.NumberFormat = "0.00"

    Range("B7").Select
    Selection.NumberFormat = "0.00%"
    Range("B9").Select
    Selection.NumberFormat = "0.00%"
    Range("B10").Select
    Selection.NumberFormat = "0.00%"
    Range("B11").Select
    Selection.NumberFormat = "0.00%"
    Range("A1").Select


End Sub

3

excel vba excel-vba excel-web-query

Источник

user7823067 10 апр '17 в 17:13

3 ответа

Другие вопросы по тегам excel vba excel-vba excel-web-query

user2165759 14 апр '17 в 22:47 2017-04-14 22:47 · Answer 1 · 2017-04-14 22:47

Вы все еще можете получить необходимые данные, анализируя ответ JSON либо из

https://finance.yahoo.com/quote/AAPL/financials
(извлечение данных из содержимого HTML, AAPL здесь только для примера)

или через API

https://query1.finance.yahoo.com/v10/finance/quoteSummary/AAPL?lang=en-US®ion=US&modules=incomeStatementHistory%2CcashflowStatementHistory%2CbalanceSheetHistory%2CincomeStatementHistoryQuarterly%2CcashflowStatementHistoryQuarterly%2CbalanceSheetHistoryQuarterly%2Cearnings

Вы можете использовать приведенный ниже код VBA для анализа ответа и вывода результата. Импортируйте модуль JSON.bas в проект VBA для обработки JSON. Вот Sub Test_query1_finance_yahoo_com() получать данные через API и Test_finance_yahoo_com_quote извлечь данные из содержимого HTML:

Option Explicit

Sub Test_query1_finance_yahoo_com()

    Dim sSymbol As String
    Dim sJSONString As String
    Dim vJSON As Variant
    Dim sState As String

    sSymbol = "AAPL"

    ' Get JSON via API
    With CreateObject("MSXML2.XMLHTTP")
        .Open "GET", "https://query1.finance.yahoo.com/v10/finance/quoteSummary/" & sSymbol & "?lang=en-US&region=US&modules=incomeStatementHistory%2CcashflowStatementHistory%2CbalanceSheetHistory%2CincomeStatementHistoryQuarterly%2CcashflowStatementHistoryQuarterly%2CbalanceSheetHistoryQuarterly%2Cearnings", False
        .Send
        sJSONString = .ResponseText
    End With
    ' Parse JSON response
    JSON.Parse sJSONString, vJSON, sState
    If sState = "Error" Then
        MsgBox "Invalid JSON"
        Exit Sub
    End If
    ' Pick core data
    Set vJSON = vJSON("quoteSummary")("result")(0)
    ' Output
    QuoteDataOutput vJSON
    MsgBox "Completed"

End Sub

Sub Test_finance_yahoo_com_quote()

    Dim sSymbol As String
    Dim sJSONString As String
    Dim vJSON As Variant
    Dim sState As String

    sSymbol = "AAPL"

    ' Get webpage HTML response
    With CreateObject("Msxml2.XMLHTTP")
        .Open "GET", "https://finance.yahoo.com/quote/" & sSymbol & "/financials", False
        .Send
        sJSONString = .ResponseText
    End With
    ' Extract JSON from HTML content
    sJSONString = "{" & Split(sJSONString, "root.App.main = {")(1)
    sJSONString = Split(sJSONString, "}(this));")(0)
    sJSONString = Left(sJSONString, InStrRev(sJSONString, "}"))
    ' Parse JSON response
    JSON.Parse sJSONString, vJSON, sState
    If sState = "Error" Then
        MsgBox "Invalid JSON"
        Exit Sub
    End If
    ' Pick core data
    Set vJSON = vJSON("context")("dispatcher")("stores")("QuoteSummaryStore")
    ' Output
    QuoteDataOutput vJSON
    MsgBox "Completed"

End Sub

Sub QuoteDataOutput(vJSON)

    Const Transposed = True ' Output option

    Dim oItems As Object
    Dim vItem
    Dim aRows()
    Dim aHeader()

    ' Fetch main structures available from JSON object to dictionary
    Set oItems = CreateObject("Scripting.Dictionary")
    With oItems
        .Add "IncomeStatementY", vJSON("incomeStatementHistory")("incomeStatementHistory")
        .Add "IncomeStatementQ", vJSON("incomeStatementHistoryQuarterly")("incomeStatementHistory")
        .Add "CashflowY", vJSON("cashflowStatementHistory")("cashflowStatements")
        .Add "CashflowQ", vJSON("cashflowStatementHistoryQuarterly")("cashflowStatements")
        .Add "BalanceSheetY", vJSON("balanceSheetHistory")("balanceSheetStatements")
        .Add "BalanceSheetQ", vJSON("balanceSheetHistoryQuarterly")("balanceSheetStatements")
        .Add "EarningsChartQ", vJSON("earnings")("earningsChart")("quarterly")
        .Add "FinancialsChartY", vJSON("earnings")("financialsChart")("yearly")
        .Add "FinancialsChartQ", vJSON("earnings")("financialsChart")("quarterly")
    End With
    ' Output each data set to separate worksheet
    For Each vItem In oItems
        ' Convert each data set to array
        JSON.ToArray oItems(vItem), aRows, aHeader
        ' Output array to worksheet
        With GetSheet((vItem))
            .Cells.Delete
            If Transposed Then
                Output2DArray .Cells(1, 1), WorksheetFunction.Transpose(aHeader)
                Output2DArray .Cells(1, 2), WorksheetFunction.Transpose(aRows)
            Else
                OutputArray .Cells(1, 1), aHeader
                Output2DArray .Cells(2, 1), aRows
            End If
            .Columns.AutoFit
        End With
    Next

End Sub

Function GetSheet(sName As String, Optional bCreate = True) As Worksheet

    On Error Resume Next
    Set GetSheet = ThisWorkbook.Sheets(sName)
    If Err Then
        If bCreate Then
            Set GetSheet = ThisWorkbook.Sheets.Add(, ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
            GetSheet.Name = sName
        End If
        Err.Clear
    End If

End Function

Sub OutputArray(oDstRng As Range, aCells As Variant)

    With oDstRng
        .Parent.Select
        With .Resize(1, UBound(aCells) - LBound(aCells) + 1)
            .NumberFormat = "@"
            .Value = aCells
        End With
    End With

End Sub

Sub Output2DArray(oDstRng As Range, aCells As Variant)

    With oDstRng
        .Parent.Select
        With .Resize( _
                UBound(aCells, 1) - LBound(aCells, 1) + 1, _
                UBound(aCells, 2) - LBound(aCells, 2) + 1)
            .NumberFormat = "@"
            .Value = aCells
        End With
    End With

End Sub

в заключение Sub QuoteDataOutput(vJSON) input - это объект JSON, чтобы было понятно, как из него извлекаются необходимые данные, вы можете сохранить строку JSON в файл, скопировать содержимое и вставить ее в любое средство просмотра JSON для дальнейшего изучения. Я использую онлайн-инструмент http://jsonviewer.stack.hu/, структура целевого элемента показана ниже:

Вывод для меня следующий (показан первый рабочий лист):

Есть 9 основных разделов, соответствующая часть данных извлекается и выводится на 9 рабочих листах:

IncomeStatementY
IncomeStatementQ
CashflowY
CashflowQ
BalanceSheetY
BalanceSheetQ
EarningsChartQ
FinancialsChartY
FinancialsChartQ

Имея этот пример, вы можете извлечь нужные данные из ответа JSON.

user1188513 10 апр '17 в 17:56 2017-04-10 17:56 · Answer 2 · 2017-04-10 17:56

Ваш код, очевидно, работает против определенного листа:

Rows("2:1000").Select

Но что это за лист? Только ты можешь знать это.

Как написано, это то, чем является активный рабочий лист, независимо от того, какой смысл это имеет.

Все эти функции безоговорочно относятся к ActiveSheet:

Range
Cells
Columns
Rows
Names

Таким образом, вы должны квалифицировать их. И вы делаете это, указывая конкретный Worksheet объект, с которым они должны работать - предположим, что это DataSheet (Понятия не имею)

DataSheet.Rows("2:1000").Select

Это было бы .Select указанные строки на листе, на которые указывает DataSheet объект.

Зачем вам нужно .Select Это? Это:

Rows("2:1000").Select
Selection.ClearContents

С таким же успехом может быть:

DataSheet.Rows("2:1000").ClearContents

Или лучше - при условии, что ваши данные отформатированы в виде таблицы (в любом случае, похоже, она выглядит так - почему бы не использовать ListObjects API):

DataSheet.ListObjects("DataTable").DataBodyRange.Delete

Похоже, эта инструкция только что заменила все .Select а также .ClearContents здесь происходит Обратите внимание, что .Select подражает пользовательскому действию - пользователь щелкает ячейку (или что-то действительно) и выбирает ее. У вас есть программный доступ ко всей объектной модели - вам никогда не нужно .Select что-нибудь!

Dim inTicker As String
inTicker = Range("A1")

Здесь вы неявно читаете с активного листа, но вы также неявно конвертируете Variant (значение ячейки) в String, который может или не может быть успешным. Если A1 содержит значение ошибки (например, #REF!) инструкция не выполняется.

With DataSheet.Range("A1")
    If Not IsError(.Value) Then 
        inTicker = CStr(.Value)
    Else
        'decide what to do then
    End If
End With

Ваша подпрограмма обработки ошибок должна как минимум Debug.Print Err.Number, Err.Description так что у вас есть немного понятия о том, почему все взорвалось. Прямо сейчас это предполагает причину сбоя, и, как вы видели, Excel полон ловушек.

Также вы используете vbLf, но это только половина правильного символа новой строки Windows. использование vbNewLine если вы не уверены, что это такое.

Exit Sub инструкция перед End Sub токен совершенно бесполезен.

Sub GetFinStats(inTicker As String)

Процедура неявно Public, а также inTicker неявно передается ByRef, Слава за то, что дал ему явный тип!

Это было бы лучше:

Private Sub GetFinStats(ByVal inTicker As String)

With ActiveSheet.QueryTables

По крайней мере, это ясно об использовании активного листа. Но следует ли использовать активный лист или конкретный лист? А что происходит с таблицами запросов, которые уже были там?

Я настоятельно рекомендую вам ввести это в ближайшей панели:

?ThisWorkbook.Connections.Count

Если число больше, чем число .QueryTables.Add вызовы, которые у вас есть в вашей процедуре (скорее всего), у вас возникла довольно серьезная проблема: я подозреваю, что у вас есть более ста соединений в книге, и нажатие кнопки "Обновить все" занимает вечность, и вполне вероятно, что finance.yahoo.com получает десятки запросов с одного IP-адреса за очень ограниченное время и отказывается их обслуживать.

Удалите все неиспользуемые подключения к книге. А потом исправь неявное ActiveSheet ссылки там тоже и избавятся от всего этого бесполезного .Select звонки:

With TheSpecificSheet

    With .QueryTables.Add( ... )
    End With

    With .QueryTables.Add( ... )
    End With

    With .QueryTables.Add( ... )
    End With

    'assgin .Value, not .FormulaR1C1; you're not entering a R1C1 formula anyway
    .Range("A3").Value = "Current Ratio"
    .Range("A4").Value = "Quick Ratio"
    .Range("A5").Value = "Cash Ratio"

End With

последовательный .Select звонки означают, что все, кроме последнего, служат цели, если таковые имеются:

Range("A6").Select
Range("A7").Select

Опять не назначайте ActiveCell когда вы можете назначить .Range("A7").Value непосредственно.

И вы можете установить числовые форматы для диапазона ячеек:

.Range("B3:B11").NumberFormat = "0.00%"

user7823067 11 апр '17 в 03:22 2017-04-11 03:22 · Answer 3 · 2017-04-11 03:22

Оказывается, Yahoo закрыла приложение, из которого веб-запрос извлек свои данные. Спасибо за все ваши советы.

0

Источник

user7823067 11 апр '17 в 03:22