Question

我正在尝试从另一个工作表上的列表中动态地从几个不同的URL导入数据。下面粘贴的代码可以导入一个，但是需要遍历几个不同的Urls。

所有新创建的表（链接到不同URL的表应一个接一个地在同一工作表上连续创建。

有人对此有任何想法吗？还是关于如何实现此目标的更简单或更妙的主意？

万分感谢，谢谢大家

Sub test()
'
'
    ActiveWorkbook.Queries.Add Name:="Table 2", Formula:= _
        "let" & Chr(13) & "" & Chr(10) & "    Source = Web.Page(Web.Contents(""https://finviz.com/screener.ashx?f=sec_basicmaterials&v=121""))," & Chr(13) & "" & Chr(10) & "    Data2 = Source{2}[Data]," & Chr(13) & "" & Chr(10) & "    #""Promoted Headers"" = Table.PromoteHeaders(Data2, [PromoteAllScalars=true])," & Chr(13) & "" & Chr(10) & "    #""Changed Type"" = Table.TransformColumnTypes(#""Promoted Headers"",{{""No."", Int64.Type}, {""Ticker"", type text}, {""Market Cap"", type te" & _
        "xt}, {""P/E"", type text}, {""Fwd P/E"", type text}, {""PEG"", type text}, {""P/S"", type text}, {""P/B"", type text}, {""P/C"", type text}, {""P/FCF"", type text}, {""EPS this Y"", type text}, {""EPS next Y"", type text}, {""EPS past 5Y"", type text}, {""EPS next 5Y"", type text}, {""Sales past 5Y"", type text}, {""Price"", type number}, {""Change"", Percentage.Typ" & _
        "e}, {""Volume"", type text}})" & Chr(13) & "" & Chr(10) & "in" & Chr(13) & "" & Chr(10) & "    #""Changed Type"""
    ActiveWorkbook.Worksheets.Add
    ActiveSheet.Range("a10").Select
    With ActiveSheet.ListObjects.Add(SourceType:=0, Source:= _
        "OLEDB;Provider=Microsoft.Mashup.OleDb.1;Data Source=$Workbook$;Location=""Table 2"";Extended Properties=""""" _
        , Destination:=Range("$A$1")).QueryTable
        .CommandType = xlCmdSql
        .CommandText = Array("SELECT * FROM [Table 2]")
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .PreserveColumnInfo = True
        .ListObject.DisplayName = "Table_2"
        .Refresh BackgroundQuery:=False
    End With

End Sub

Answer 1

以其他方式进行操作又如何呢？请尝试并提供反馈。

' XMLHTTP request:

Option Explicit
Public Sub GetTable()
    Dim sResponse As String, html As HTMLDocument, hTable As Object
    Set html = New HTMLDocument
    With CreateObject("MSXML2.XMLHTTP")
        .Open "GET", "https://finviz.com/screener.ashx?v=152", False
        .setRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT"
        .send
        sResponse = StrConv(.responseBody, vbUnicode)
    End With

    With html
        .body.innerHTML = sResponse
        Set hTable = .getElementsByTagName("tbody")(9)
        WriteTable hTable, 1, ThisWorkbook.Worksheets("Sheet1")
    End With
End Sub

Public Sub WriteTable(ByVal hTable As Object, Optional ByVal startRow As Long = 1, Optional ByVal ws As Worksheet)
    If ws Is Nothing Then Set ws = ActiveSheet
    Dim tRow As Object, tCell As Object, tr As Object, td As Object, r As Long, c As Long
    r = startRow
    With ws
        Set tRow = hTable.getElementsByTagName("tr")
        For Each tr In tRow
            r = r + 1: c = 1
            Set tCell = tr.getElementsByTagName("td")
            For Each td In tCell
                .Cells(r, c).Value = td.innerText
                c = c + 1
            Next td
        Next tr
    End With
End Sub

从多个URL导入数据

1 个答案: