VBA xmlhttp GET - 不規則な構造のテーブルからデータを取得する

Question

私はxmlhttp GETを通してウェブサイトからデータを取得しようとしています。いくつかのセルがマージされているため、残念ながらテーブルには列の行数が一定ではありません（第1行の列数が少ないため、手動でマクロの最大量を11に変更する必要があります）。

出力をウェブサイトと正確に一致させたいと思います。

Option Explicit 

Public Sub GetTable() 

Dim oDom As Object: Set oDom = CreateObject("htmlFile") 
Dim x As Long, y As Long 
Dim oRow As Object, oCell As Object 
Dim vData As Variant 
Dim link As String 

link = "http://medicarestatistics.humanservices.gov.au/statistics/do.jsp?_PROGRAM=%2Fstatistics%2Fmbs_group_standard_report&DRILL=on&GROUP=Broad+Type+of+Service+%28BTOS%29&VAR=services&STAT=count&RPT_FMT=by+time+period+and+state&PTYPE=month&START_DT=201609&END_DT=201609" 

y = 1: x = 1 

With CreateObject("msxml2.xmlhttp") 
    .Open "GET", link, False 
    .Send 
    oDom.body.innerHtml = .responseText 
End With 

With oDom.getelementsbytagname("table")(0) 
    ReDim vData(1 To .Rows.Length, 1 To 11) '.Rows(1).Cells.Length) 
    For Each oRow In .Rows 
     For Each oCell In oRow.Cells 
      vData(x, y) = oCell.innerText 
      y = y + 1 
     Next oCell 
     y = 1 
     x = x + 1 
    Next oRow 
End With 

Sheets(1).Cells(1, 1).Resize(UBound(vData), UBound(vData, 2)).Value = vData 
End Sub 

Answer 1

ちょうどあなたのループを通って行の長さを毎回チェックして、あなたがより多くの列が必要な場合は、配列のサイズを変更：

With oDom.getelementsbytagname("table")(0) 
    Dim rowCount As Long 
    rowCount = .Rows.Length 
    ReDim vData(1 To rowCount, 1 To .Rows(0).Cells.Length) 
    For Each oRow In .Rows 
     Dim columnCount As Long 
     columnCount = .Rows(x - 1).Cells.Length 
     If columnCount > UBound(vData, 2) Then 
      ReDim Preserve vData(1 To rowCount, 1 To columnCount) 
     End If 
     For Each oCell In oRow.Cells 
      vData(x, y) = oCell.innerText 
      y = y + 1 
     Next oCell 
     y = 1 
     x = x + 1 
    Next oRow 
End With 

EDIT：

が列をチェックしていなかったのでまたがりますソーステーブル1つのオプションは、@ Thunderframeの提案とすべての列スパンのテストを使用することですが、それはちょっと面倒です。私は個人的にExcelがクリップボードからのHTMLを貼り付ける方法を知っているという事実を活用し、ちょうどExcelがそれを把握しましょうと思います：

With oDom.getelementsbytagname("table")(0) 
    Dim dataObj As Object 
    Set dataObj = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") 
    dataObj.SetText "<table>" & .innerHtml & "</table>" 
    dataObj.PutInClipboard 
End With 

Sheets(1).Paste Sheets(1).Cells(1, 1)