Перенос данных веб-страницы в рабочую таблицу Excel с использованием VBA

Question

Это мой первый пост. Я новичок в VBA, но я довольно хорошо знаком с VB6. Я написал код, который берет текст из NASDAQ и вставляет его в лист. Это наконец работает. Существует много посторонних данных, разбросанных выше и ниже Годового отчета о доходах. Я хотел бы проанализировать и разместить важные данные в месте, где я могу автоматизировать анализ. Я думаю, что могу искать в ячейках, пока не найду: отчет о годовом доходе и выписка на другой лист. Любые предложения будут очень признательны. Вот что у меня есть:

Sub TransferWebData()
Dim IE As Object
Set IE = CreateObject("InternetExplorer.Application")
With IE
    .Visible = True
    .Navigate "http://www.nasdaq.com/symbol/gd/financials" 
    Do Until .ReadyState = 4: DoEvents: Loop
    IE.ExecWB 17, 0 'SelectAll
    IE.ExecWB 12, 2 'Copy selection

    Sheets("GD").Range("A1").Select
    Sheets("GD").PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False, NoHTMLFormatting:=True
    IE.Quit
End With
End Sub

Answer 1

Вы также можете импортировать позиции отчета о прибылях и убытках для нескольких тикеров акций.

Sub ImportYrlyFS()
ThisSheet = ActiveSheet.Name
Range("A2").Select
Do Until ActiveCell.Value = ""
Symbol = ActiveCell.Value
Sheets(ThisSheet).Select
Sheets.Add
Dim QT As QueryTable
Symbol = UCase(Symbol)
myurl = "http://finance.yahoo.com/q/is?s=" & Symbol & "+Income+Statement&annual"
Set QT = ActiveSheet.QueryTables.Add( _
Connection:="URL;" & myurl, _
Destination:=Range("A1"))
With QT
.WebSelectionType = xlSpecifiedTables
.WebTables = "9"
.Refresh BackgroundQuery:=False
End With
QT.Delete
Sheets(ActiveSheet.Name).Name = Symbol
Sheets(ThisSheet).Select
ActiveCell.Offset(1, 0).Select
Loop
End Sub

Ваш лист должен выглядеть следующим образом.

Answer 2

Посмотрите на приведенный ниже пример получения данных с использованием XHR и RegEx без автоматизации IE:

Option Explicit

Sub GetDataFromNasdaq()

    Dim sContent As String
    Dim l As Long
    Dim i As Long
    Dim j As Long
    Dim cMatches As Object
    Dim r() As String

    ' retrieve html content
    With CreateObject("MSXML2.XMLHTTP")
        .Open "GET", "http://www.nasdaq.com/symbol/gd/financials", False
        .Send
        sContent = .ResponseText
    End With
    ' parse with regex
    With CreateObject("VBScript.RegExp")
        .MultiLine = True
        .IgnoreCase = True
        ' simplification
        .Global = True
        .Pattern = "<(\w*) .*?>"
        sContent = .Replace(sContent, "<$1>")
        .Pattern = ">\s*<"
        sContent = .Replace(sContent, "><")
        .Pattern = "<thead>|<tbody>|</thead>|</tbody>"
        sContent = .Replace(sContent, "")
        .Pattern = "<(/?)th>"
        sContent = .Replace(sContent, "<$1td>")
        ' remove nested tables from target table
        .Global = False
        .Pattern = "(Annual Income Statement[\s\S]*?<table.*?>(?:(?!</table)[\s\S])*)<table.*?>(?:(?!<table|</table)[\s\S])*</table>"
        Do
            l = Len(sContent)
            sContent = .Replace(sContent, "$1")
        Loop Until l = Len(sContent)
        ' trim target table
        .Pattern = "Annual Income Statement[\s\S]*?(<table.*?>(?:(?!</table)[\s\S])*</table>)"
        sContent = .Execute(sContent).Item(0).SubMatches(0)
        ' match rows
        .Global = True
        .Pattern = "<tr><td>(.*?)</td>(?:<td>.*?</td><td>(.*?)</td><td>(.*?)</td><td>(.*?)</td><td>(.*?)</td>)?</tr>"
        Set cMatches = .Execute(sContent)
        ' populate resulting array
        ReDim r(1 To cMatches.Count, 1 To 5)
        For i = 1 To cMatches.Count
            For j = 1 To 5
                r(i, j) = cMatches(i - 1).SubMatches(j - 1)
            Next
        Next
    End With
    ' ouput resulting array
    With ThisWorkbook.Sheets(1)
        Cells.Delete
        Output .Cells(1, 1), r
    End With
End Sub

Sub Output(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
            .Columns.AutoFit
        End With
    End With
End Sub

Требуется около 2 секунд, чтобы завершить обработку, вывод выглядит следующим образом:

Answer 3

Это должно занять вас.

Установить ссылки на Microsoft HTML Object Library и Microsoft Internet Controls.

В Google Chrome я перешел на веб-страницу и с помощью элемента inspect открыл WebKit и скопировал xpath в этот элемент. Это дало мне и набросок, чтобы составить черновик моей функции. После полутора часов утомительной отладки я смог извлечь данные в массив.

// * [@ id = "financials-iframe-wrap"] / div 1/ table / tbody / tr 1/ td 2

Sub TransferWebData()
    Dim Data
    Dim IE As Object
    Set IE = CreateObject("InternetExplorer.Application")
    With IE
        .Visible = True
        .Navigate "http://www.nasdaq.com/symbol/gd/financials"
        Do Until .ReadyState = 4: DoEvents: Loop

        Data = getFinancialsArray(IE.document)
        With Worksheets("GD")
            .Cells.ClearContents
            .Range("A1").Resize(UBound(Data, 1) + 1, UBound(Data, 2)).Value = Data
            .Columns.AutoFit
        End With
        IE.Quit
    End With
End Sub

' //*[@id="financials-iframe-wrap"]/div[1]/table/tbody/tr[1]/td[2]

Function getFinancialsArray(doc As HTMLDocument)
    Dim Data
    Dim x As Long, y As Long, y1 As Long
    Dim divfinancials As HTMLDivElement, div1 As HTMLDivElement
    Dim tbl As HTMLTable, allRows
    Set divfinancials = doc.getElementById("financials-iframe-wrap")
    Set div1 = divfinancials.getElementsByTagName("div").Item(0)
    Set tbl = div1.getElementsByTagName("table").Item(0)
    Set allRows = tbl.getElementsByTagName("tr")
    Dim s As String
    ReDim Data(allRows.Length, 10)
    For y = 0 To allRows.Length - 1
        If Len(Trim(allRows.Item(y).innerText)) Then    'If the row has data
            For x = 0 To allRows.Item(y).Cells.Length - 1
                Data(y1, x) = allRows.Item(y).Cells(x).innerText
            Next
            y1 = y1 + 1
        End If
    Next
    getFinancialsArray = Data
End Function

Выход