从具有多个页面的网站中抓取数据

Question

https://finviz.com/screener.ashx?v=152&f=cap_midover&c=1,16,17,18,65

我想使用 VBA 从上面的网站上抓取数据，以便获得我想要的 5 列（Ticker、EPS、EPS this Y、EPS next Y、Price）。有 99 个页面需要循环，每个页面有 20 个代码，这意味着我需要抓取近 2000 行数据。我可以通过使用 PowerQuery 来做到这一点，但如果我使用 PowerQuery，刷新数据似乎需要大约 3 分钟。

我不确定我是否使用 VBA 来抓取数据是否能够加快数据刷新所花费的时间。我是 VBA 新手，下面是我的代码，它为我提供了整个网站页面的输出（不是我想要的），并且代码不会遍历 1-99 的不同页面。

Sub GetFinvizData()
 
Dim str As String
 
'Delete existing data
Sheets("Data").Activate 'Name of sheet the data will be downloaded into. Change as required.
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
 
'Download stock quotes. Be patient - takes a few seconds.
str = "https://finviz.com/screener.ashx?v=152&f=cap_midover&r=1&c=1,16,17,18,65"
QueryQuote:
            With Sheets("Data").QueryTables.Add(Connection:="URL;" & str, Destination:=Sheets("Data").Range("a1"))
                .BackgroundQuery = True
                .TablesOnlyFromHTML = False
                .refresh BackgroundQuery:=False
                .SaveData = True
            End With
 
Sheets("Data").Range("a1").CurrentRegion.TextToColumns Destination:=Sheets("Data").Range("a1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=False, Comma:=True, Space:=False, other:=True, OtherChar:=",", FieldInfo:=Array(1, 2)
 
Sheets("Data").Columns("A:B").ColumnWidth = 12
Range("A1").Select
 
End Sub

Answer 1

尝试以下方法以在该站点的所有页面中获取上述字段：

Option Explicit
Sub FetchTabularData()
    Const base$ = "https://finviz.com/"
    Dim elem As Object, S$, R&, oPage As Object, nextPage$
    Dim Http As Object, Html As Object, ws As Worksheet, Url$
    
    Set ws = ThisWorkbook.Worksheets("Data")
    Set Http = CreateObject("MSXML2.XMLHTTP")
    Set Html = CreateObject("HTMLFile")
    
    Url = "https://finviz.com/screener.ashx?v=152&f=cap_midover&r=1&c=1,16,17,18,65"
    
    ws.Range("A1:E1") = Array("Ticker", "EPS", "EPS This Y", "EPS Next Y", "Price")
    
    R = 1
    
    While Url <> ""
        With Http
            .Open "GET", Url, False
            .setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/85.0.4183.121 Safari/537.36"
            .send
            S = .responseText
        End With
    
        With Html
            .body.innerHTML = S
            For Each elem In .getElementById("screener-content").getElementsByTagName("tr")
                If InStr(elem.className, "table-dark-row-cp") > 0 Or InStr(elem.className, "table-light-row-cp") > 0 Then
                    R = R + 1: ws.Cells(R, 1) = elem.Children(0).innerText
                    ws.Cells(R, 2) = elem.Children(1).innerText
                    ws.Cells(R, 3) = elem.Children(2).innerText
                    ws.Cells(R, 4) = elem.Children(3).innerText
                    ws.Cells(R, 5) = elem.Children(4).innerText
                End If
            Next elem
            
            Url = vbNullString
            
            For Each oPage In .getElementsByTagName("a")
                If InStr(oPage.className, "tab-link") And InStr(oPage.innerText, "next") > 0 Then
                    nextPage = oPage.getAttribute("href")
                    Url = base & Replace(nextPage, "about:", "")
                End If
            Next oPage
        End With
    Wend
End Sub

您无需向参考库添加任何内容即可执行上述脚本。

Answer 2

这是我学习 vba 的第四天，所以不要期望太多...另外我不知道如何循环浏览不同的页面并将数据放入您的工作表中，所以这不会解决您的问题...但是……

我仍然认为我应该提出我的想法，这只是我的意见。 如果您要为每个 pg 制作不同的工作表，那么您可以使用下面给出的代码删除您不需要的垃圾内容。我认为垃圾将被限制在特定范围内，因此您可以在它进入工作表后将其删除......如果您能够做到这一点，那么这段代码仍然不会将所有页面放入不同的工作表中，那么接下来可以这样做。

Sub GetFinvizData()
Application.DisplayAlerts = False
Dim str As String
 
'Delete existing data
ActiveSheet.Activate 'Name of sheet the data will be downloaded into. Change as required.
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
 
'Download stock quotes. Be patient - takes a few seconds.
str = "https://finviz.com/screener.ashx?v=152&f=cap_midover&r=1&c=1,16,17,18,65"
QueryQuote:
            With ActiveSheet.QueryTables.Add(Connection:="URL;" & str, Destination:=ActiveSheet.Range("a1"))
                .BackgroundQuery = True
                .TablesOnlyFromHTML = False
                .Refresh BackgroundQuery:=False
                .SaveData = True
            End With
 
ActiveSheet.Range("a1").CurrentRegion.TextToColumns Destination:=ActiveSheet.Range("a1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=False, Comma:=True, Space:=False, other:=True, OtherChar:=",", FieldInfo:=Array(1, 2)
 
ActiveSheet.Columns("A:B").ColumnWidth = 12

' DeleteJunk
'

'

    Rows("1:20").Select
    Range("1:20,42:58").Select
    Selection.Delete Shift:=xlUp

Range("A1").Select
 
End Sub