VBA xmlhttp GET - Daten von Tabelle mit unregelmäßiger Struktur erhalten

Question

Ich versuche, Daten von der Website durch xmlhttp GET zu bekommen. Leider hat die Tabelle keine konstante Anzahl von Spalten in einer Zeile oder Zeilen in einer Spalte, da einige Zellen zusammengeführt werden (ich musste sogar die maximale Anzahl von Spalten manuell auf 11 im Makro ändern, da die erste Zeile weniger Spalten hat).

Ich möchte die Ausgabe genau wie auf der Website gehen.

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

überprüfen Sie die Zeilenlänge jedes Mal durch Ihre Schleife und die Array-Größe ändern, wenn Sie mehr Spalten benötigen:

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:

Haben Sie nicht überprüfen Sie die Spalte erstreckt sich in die Quellentabelle Eine Option wäre, den Vorschlag von @ Thunderframe zu verwenden und auf alle Spaltenspannen zu testen, aber das erscheint ein wenig mühsam. Ich würde persönlich die Tatsache nutzen, dass Excel weiß, wie HTML-Code aus der Zwischenablage einzufügen, und lassen Sie Excel es herauszufinden:

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)