Я не думаю, что ваш код будет работать, если не будет хотя бы одного On Error Resume Next, скрывающего некоторые ошибки времени выполнения. Например, у вас есть If http2.Status = 200 Then до создания экземпляра объекта http2.
Ниже приведен метод, который определенно можно улучшить, но он использует класс для хранения объекта xmlhttp и предоставляет методы для получения необходимой информации. Макет желаемой таблицы делает анализ текущей веб-страницы особенно сложным. Вы можете остаться с этим. Я решил использовать структуру таблицы как есть. Возможно, это может дать вам основу по крайней мере. Вы бы добавили в него свои пользовательские дополнительные вызовы оптимизации.
TODO:
Посмотрите, можно ли сделать оценку для массива результатов увеличенного размера, который может содержать все результаты, а не массив массивов, так что выписка может быть выполнена на ходу. Если у меня будет время, я внесу эту поправку.
Класс clsHTTP
Option Explicit
Private http As Object
Const SEARCH_TERM As String = "(List all Funds and Classes/Contracts"
Private Sub Class_Initialize()
Set http = CreateObject("MSXML2.XMLHTTP")
End Sub
Public Function GetString(ByVal Url As String, Optional ByVal search As Boolean = False) As String
Dim sResponse As String
searchTermFound = False
With http
.Open "GET", Url, False
.setRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT"
.send
sResponse = StrConv(.responseBody, vbUnicode)
If InStr(sResponse, SEARCH_TERM) > 0 Then searchTermFound = True
GetString = sResponse
End With
End Function
Public Function GetLink(ByVal html As HTMLDocument) As String
Dim i As Long, nodeList As Object
Set nodeList = html.querySelectorAll("a")
GetLink = vbNullString
For i = 0 To nodeList.Length - 1
If InStr(nodeList.item(i).innerText, SEARCH_TERM) > 0 Then
GetLink = Replace$(nodeList.item(i).href, "about:/", "https://www.sec.gov/")
Exit For
End If
Next
End Function
Public Function GetInfo(ByVal html As HTMLDocument) As Variant
Dim CIK As String, table As HTMLTable, tables As Object, tRows As Object
Dim arr(), tr As Object, td As Object, r As Long, c As Long
Set tables = html.querySelectorAll("table")
If tables.Length > 3 Then
CIK = "'" & html.querySelector(".search").innerText
Set table = tables.item(3)
Set tRows = table.getElementsByTagName("tr")
ReDim arr(1 To tRows.Length, 1 To 6)
Dim numColumns As Long, numBlanks As Long
For Each tr In tRows
numColumns = tr.getElementsByTagName("td").Length
r = r + 1: c = 2: numBlanks = 0
If r > 4 Then
arr(r - 4, 1) = CIK
For Each td In tr.getElementsByTagName("td")
If td.innerText = vbNullString Then numBlanks = numBlanks + 1
arr(r - 4, c) = td.innerText
c = c + 1
Next td
If numBlanks = numColumns Then Exit For
End If
Next
Else
ReDim arr(1, 1)
GetInfo = arr
Exit Function
End If
arr = Application.Transpose(arr)
ReDim Preserve arr(1 To 6, 1 To r - 4)
arr = Application.Transpose(arr)
GetInfo = arr
End Function
Стандартный модуль 1
Option Explicit
Public searchTermFound As Boolean
Public Sub GetInfo()
Dim wsLinks As Worksheet, links(), link As Long, http As clsHTTP
Dim lastRow As Long, html As HTMLDocument, newURL As String
Set wsLinks = ThisWorkbook.Worksheets("CIK_Links")
Set http = New clsHTTP
Set html = New HTMLDocument
With wsLinks
lastRow = GetLastRow(wsLinks, 3)
If lastRow = 2 Then
ReDim links(1, 1)
links(1, 1) = .Range("C2").Value
Else
links = .Range("C2:C" & lastRow).Value
End If
End With
Dim results(), arr(), i As Long, j As Long
ReDim results(1 To UBound(links, 1))
For link = LBound(links, 1) To UBound(links, 1)
If InStr(links(link, 1), "https://www.sec.gov") > 0 Then
html.body.innerHTML = http.GetString(links(link, 1), True)
If searchTermFound Then
newURL = http.GetLink(html)
html.body.innerHTML = http.GetString(newURL, False)
arr = http.GetInfo(html)
If UBound(arr, 1) > 1 Then
i = i + 1
results(i) = arr
End If
End If
End If
Next
Dim wsOut As Worksheet
Set wsOut = ThisWorkbook.Worksheets("Parsed_Tables")
For j = 1 To i
arr = results(j)
With wsOut
.Cells(GetLastRow(wsOut, 1), 1).Resize(UBound(arr, 1), UBound(arr, 2)) = arr
End With
Next
End Sub
Public Function GetLastRow(ByVal ws As Worksheet, Optional ByVal columnNumber As Long = 1) As Long
With ws
GetLastRow = .Cells(.Rows.Count, columnNumber).End(xlUp).Row
End With
End Function