网站数据表格刮板

Question

在我提出问题之前，我是一名业余编码员，除了 VBA 之外，在 ms office 应用程序中基本上没有任何有意义的经验（我知道 - 菜鸟！）

我正在尝试创建一个使用 VBA 将数据导入 excel 的网络爬虫，并且根据我在下面的代码摘录中的 cmets，我能找到的最好的答案是 @ 987654321@.

下面，我以invest.com 为例，但实际上我的项目将跨越多个站点，并将输入到一个矩阵中，该矩阵将每天更新并随着事件到期而自我蚕食 - 因此我宁愿预先在代码方面的工作量，以尽可能减少持续的输入（对我而言）。

考虑到这一点，请问是否有办法执行以下任何操作（振作起来，这对某些人来说是令人畏惧的基础知识）：

1. 有没有一种方法可以让我导航到一个 url 并在该页面上的每个表上运行 for each 循环（没有任何已知的 id）？这是为了加快我的代码速度，同时尽量减少我的输入，因为会有相当多的数据需要更新，我计划在刷新时设置一个 2 分钟的循环触发器。

2. 除了我在下面做的事情之外，是否可以引用一个表而不是一行，并按照 Cells(2,5).value 的行执行某些操作以返回其中的值第 1 行，第 4 列？ （假设两个数组索引在两个维度上都从 0 开始？）除此之外，我的第一列（在某些方面我的主键）可能在所有源上的顺序不同，所以有什么方法可以做相当于Columns("A:A").Find(What:=[Primary key], After:=Cells(1, 1), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True, SearchFormat:=False).Row 来查找表中的哪一行与我要查找的内容相关？

代码：

Sub Scraper()
Dim appIE, allRowOfData As Object

' As per https://stackoverflow.com/questions/27066963/scraping-data-from-website-using-vba

Set appIE = CreateObject("internetexplorer.application")

With appIE
   .Navigate "http://uk.investing.com/rates-bonds/financial-futures" 'Sample page
   .Visible = False
End With

Do While appIE.Busy
    Application.Wait (Now + TimeValue("0:00:01")) 'If page not open, wait a second befor trying again
Loop

Set allRowOfData = appIE.document.getElementById("pair_8907") 
'tr id="[ID of row within table]"
Dim myValue As String: myValue = allRowOfData.Cells(8).innerHTML 
'The 8 is the column number of the table 
'(note: column numbers start at 0 so the 9th column should have "8" entered here

Set appIE = Nothing

Range("A1").Value = myValue

End Sub

Answer 1

如果您想使用 Excel 函数来导航表格，为什么不先将表格转储到工作表上，此代码对我有用

Option Explicit

Sub Scraper()
    Dim appIE As Object

    ' As per http://stackoverflow.com/questions/27066963/scraping-data-from-website-using-vba

    Set appIE = CreateObject("internetexplorer.application")

    With appIE
       .Navigate "http://uk.investing.com/rates-bonds/financial-futures" 'Sample page
       .Visible = True
    End With

    Do While appIE.Busy
        DoEvents
        Application.Wait (Now + TimeValue("0:00:01")) 'If page not open, wait a second befor trying again
    Loop

    'Debug.Print TypeName(appIE.document)

    Dim doc As Object 'MSHTML.HTMLDocument
    Set doc = appIE.document

    '* appIE busy is good but you need to wait for the whole document to completely load and initialise so use this
    While doc.readyState <> "complete"
        DoEvents
    Wend

    '* we can select all the tables because they share the same CSS class name
    Dim tablesSelectedByClass As Object 'MSHTML.HTMLElementCollection
    Set tablesSelectedByClass = doc.getElementsByClassName("genTbl")

    '* you can change this, it was just convenient for me to add sheets to my workbook
    Dim shNewResults As Excel.Worksheet
    Set shNewResults = ThisWorkbook.Worksheets.Add

    Dim lRowCursor As Long  '* this controls pasting down the sheet
    lRowCursor = 1

    Dim lTableIndexLoop As Long
    For lTableIndexLoop = 0 To tablesSelectedByClass.Length - 1

        Dim tableLoop As Object 'MSHTML.HTMLTable
        Set tableLoop = tablesSelectedByClass.Item(lTableIndexLoop)

        If LenB(tableLoop.ID) > 0 Then  '* there are some extra nonsense tables, this subselects

            Dim sParentColumn As String, objParentColumn As Object ' MSHTML.HTMLSemanticElement
            Set objParentColumn = FindMyColumn(tableLoop, sParentColumn) '* need to understand is table on left hand or right hand side

            Dim vHeader As Variant: vHeader = Empty
            If sParentColumn = "leftColumn" Then
                '* tables on the left have a preceding H3 element with the table's description
                Dim objH3Headers As Object
                Set objH3Headers = objParentColumn.getElementsByTagName("H3")
                vHeader = objH3Headers.Item(lTableIndexLoop).innerText
            Else
                '* tables on the right have a hidden attribute we can use
                vHeader = tableLoop.Attributes.Item("data-gae").Value
                If Len(vHeader) > 3 Then
                    vHeader = Mid$(vHeader, 4)
                    Mid$(vHeader, 1, 1) = Chr(Asc(Mid$(vHeader, 1, 1)) - 32)
                End If
            End If

            '* tables on the right do not have column headers
            Dim bHasColumnHeaders As Boolean
            bHasColumnHeaders = (tableLoop.ChildNodes.Length = 2)

            Dim vTableCells() As Variant   '* this will be our table data container which we will paste in one go
            Dim lRowCount As Long: lRowCount = 0
            Dim lColumnCount As Long: lColumnCount = 0
            Dim lDataHeadersSectionIdx As Long: lDataHeadersSectionIdx = 0
            Dim objColumnHeaders As Object: Set objColumnHeaders = Nothing

            If bHasColumnHeaders Then

                Set objColumnHeaders = tableLoop.ChildNodes.Item(0).ChildNodes.Item(0)

                lRowCount = lRowCount + 1

                lDataHeadersSectionIdx = 1
            Else
                lDataHeadersSectionIdx = 0
            End If

            Dim objDataRows As Object 'MSHTML.HTMLElementCollection
            Set objDataRows = tableLoop.ChildNodes.Item(lDataHeadersSectionIdx).ChildNodes
            lColumnCount = objDataRows.Item(0).ChildNodes.Length

            lRowCount = lRowCount + objDataRows.Length

            ReDim vTableCells(1 To lRowCount, 1 To lColumnCount) As Variant

            '* we have them get the column headers
            Dim lColLoop As Long
            If bHasColumnHeaders Then
                For lColLoop = 1 To lColumnCount
                    vTableCells(1, lColLoop) = objColumnHeaders.ChildNodes.Item(lColLoop - 1).innerText
                Next
            End If

            '* get the data cells
            Dim lRowLoop As Long
            For lRowLoop = 1 To lRowCount - VBA.IIf(bHasColumnHeaders, 1, 0)
                For lColLoop = 1 To lColumnCount
                    vTableCells(lRowLoop + VBA.IIf(bHasColumnHeaders, 1, 0), lColLoop) = objDataRows.Item(lRowLoop - 1).ChildNodes.Item(lColLoop - 1).innerText
                Next
            Next

            '* paste our table description
            shNewResults.Cells(lRowCursor, 1).Value2 = vHeader
            lRowCursor = lRowCursor + 1

            '* paste our table data
            shNewResults.Cells(lRowCursor, 1).Resize(lRowCount, lColumnCount).Value2 = vTableCells
            lRowCursor = lRowCursor + lRowCount + 1
        End If

    Next

End Sub

Function FindMyColumn(ByVal node As Object, ByRef psColumn As String) As Object
    '* this code ascends the DOM looking for "column" in the id of each node
    While InStr(1, node.ID, "column", vbTextCompare) = 0 And Not node.ParentNode Is Nothing
        DoEvents
        Set node = node.ParentNode
    Wend
    If InStr(1, node.ID, "column", vbTextCompare) > 0 Then
        Set FindMyColumn = node
        psColumn = CStr(node.ID)
    End If


End Function

顺便说一句，如果你交易很多，经纪人会变得富有，而你会变得贫穷，从长远来看，经纪费确实会产生影响。