Блог

Я хотел бы узнать больше о том, как применяется функция массива при удалении данных с веб-сайта. В настоящее время я использую этот vba для копирования данных с веб-сайта. Код может очистить нужные мне данные, однако, когда дело доходит до копирования данных на целевой лист, он копирует все данные в A1 ячейку. Поскольку этот vba был разработан для моего предыдущего проекта и работает нормально, я не уверен, какая часть пошла не так.

 Sub CopyFromHKAB()  Dim ie As Object, btnmore As Object, tbl As Object  Dim rr As Object, cc As Object, r As Integer, c As Integer, i As Integer, j As Integer    ThisWorkbook.Sheets("data").UsedRange.Clear    Set ie = CreateObject("internetexplorer.application")  With ie  .Visible = True  .navigate "https://www.hkab.org.hk/DisplayMemberAction.do?sectionid=4amp;subsectionid=0"    Do  DoEvents  Loop While .readyState lt;gt; 4 Or .Busy      Set tbl = .document.getElementsByClassName("etxtmed")(2)    End With    'get data from table  r = tbl.Rows.Length - 1  c = tbl.Rows(0).Cells.Length - 1    ReDim arr(0 To r, 0 To c)    Set rr = tbl.Rows  For i = 0 To r  Set cc = rr(i).Cells  For j = 0 To c  arr(i, j) = cc(j).innertext  Next    Next    ie.Quit    Application.ScreenUpdating = False  ThisWorkbook.Sheets("Sheet1").Cells(1, 1).Resize(r   1, c   1) = arr    With ThisWorkbook.Sheets("data")  .UsedRange.WrapText = False  .Columns.AutoFit  End With   End Sub  

Вам нужно выбрать правильную таблицу, учитывая, что они вложены, поэтому измените индекс на 3. В противном случае вы выбираете общий родительский элемент, и, таким образом, все списки фактически находятся в пределах одного дочернего элемента, следовательно, ваш текущий вывод.

Затем вам нужно настроить свой код, чтобы пропустить первую строку.

N. B. На самом деле вам для этого не нужен IE, так как контент, который вы хотите, статичен. Вы можете использовать XMLHTTP. И вы записываете данные на другой лист, отличный от того, который вы форматируете.

 Sub CopyFromHKAB()  Dim ie As Object, btnmore As Object, tbl As Object  Dim rr As Object, cc As Object, r As Integer, c As Integer, i As Integer, j As Integer    ThisWorkbook.Sheets("data").UsedRange.Clear    Set ie = CreateObject("internetexplorer.application")  With ie  .Visible = True  .navigate "https://www.hkab.org.hk/DisplayMemberAction.do?sectionid=4amp;subsectionid=0"    Do  DoEvents  Loop While .readyState lt;gt; 4 Or .Busy      Set tbl = .document.getElementsByClassName("etxtmed")(3)    End With    'get data from table  r = tbl.Rows.Length - 1  c = tbl.Rows(1).Cells.Length - 1    ReDim arr(0 To r, 0 To c)   Set rr = tbl.Rows   For i = 1 To r    Set cc = rr(i).Cells  For j = 0 To c  arr(i - 1, j) = cc(j).innertext  Next    Next    ie.Quit    'Application.ScreenUpdating = False  ThisWorkbook.Sheets("Sheet1").Cells(1, 1).Resize(r   1, c   1) = arr   With ThisWorkbook.Worksheets("data")  .UsedRange.WrapText = False  .Columns.AutoFit  End With   End Sub  

Я бы подумал о переходе на XHR, чтобы избежать накладных расходов браузера, и querySelectorAll о том, чтобы разрешить использовать список селекторов css только для интересующих узлов

 Option Explicit  Public Sub GetHKABInfo()  'tools gt; references gt; Microsoft HTML Object Library  Dim html As MSHTML.HTMLDocument, xhr As Object    Set xhr = CreateObject("MSXML2.XMLHTTP")  Set html = New MSHTML.HTMLDocument    With xhr  .Open "GET", "https://www.hkab.org.hk/DisplayMemberAction.do?sectionid=4amp;subsectionid=0", False  .setRequestHeader "User-Agent", "Safari/537.36"  .send  html.body.innerHTML = .responseText  End With    Dim arr() As Variant, nodes As MSHTML.IHTMLDOMChildrenCollection, i As Long    Set nodes = html.querySelectorAll(".etxtmed .etxtmed td")    ReDim arr(1 To nodes.Length - 1)    For i = LBound(arr) To UBound(arr)  arr(i) = nodes.Item(i).innertext  Next    ThisWorkbook.Worksheets("Sheet1").Cells(1, 1).Resize(UBound(arr), 1) = Application.Transpose(arr)   End Sub