Druga wersja funkcji importującej Tabelę HTML do tablicy oraz
przykłady importu danym z Arkusza Google Spreadsheets wykorzystujące Query Language
  strona główna:
A po co ten Excel ;-)
 
 
 
 
 
  Wersja 1
No właśnie… wersja druga :-) Nie ma już potrzeby tworzenia instancji IE przez co funkcja działa zdecydowanie szybciej. Mechanizm   Dane z tabeli HTML do tablicy
pozostał jednak taki sam. Ciekawych pomysłu tworzenia tablicy z tabeli HTML zapraszam do lekturki poprzedniej wersji.  
 
Po nowemu byłoby tak :-)  
 
Function HTMLTable2tbl(strHTTP As String, Optional tblNr As Variant = 0)  
    On Error GoTo HTMLTable2tbl_Error  
 
    Dim msXML As Object  
    Dim htmlDocument As Object  
      
    Set msXML = CreateObject("WinHttp.WinHttpRequest.5.1")  
    Set htmlDocument = CreateObject("HtmlFile")  
    With msXML  
        .Open "GET", strHTTP  
        .send  
        .WaitForResponse  
        htmlDocument.body.innerHTML = .responseText  
    End With  
      
    Dim ieTables As Object, ieTable As Object 'MSHTML.HTMLTable  
    Dim ieRows As Object, ieRow As Object 'MSHTML.HTMLTableRow  
    Dim ieCells As Object, ieCell As Object 'MSHTML.HTMLTableCell  
    Dim tbl() As Variant, i As Long, j As Long  
          
    Set ieTables = htmlDocument.all.tags("TABLE")  
    Set ieTable = ieTables(tblNr)  
    Set ieRows = ieTable.Rows  
    For Each ieRow In ieRows  
        i = i + 1  
        Set ieCells = ieRow.Cells  
        For Each ieCell In ieCells  
            j = j + 1  
            If i = 1 And j = 1 Then  
                ReDim tbl(1 To ieTable.Rows.Length, _  
                          1 To ieRow.Cells.Length)  
            End If  
            If j > UBound(tbl, 2) Then  
                ReDim Preserve tbl(1 To ieTable.Rows.Length, _  
                                   1 To ieRow.Cells.Length)  
            End If  
            tbl(i, j) = ieCell.innerText  
        Next  
        j = 0  
    Next  
    HTMLTable2tbl = tbl  
 
HTMLTable2tbl_Exit:  
    On Error Resume Next  
 
    Set ieTables = Nothing  
    Set ieRows = Nothing  
    Set ieCells = Nothing  
    Set htmlDocument = Nothing  
    Set msXML = Nothing  
      
    Exit Function  
              
HTMLTable2tbl_Error:  
     MsgBox "Błąd Nr - " & Err.Number & vbCrLf & vbCrLf & _  
            Err.Description, vbExclamation, "VBAProject - HTMLTable2tbl"  
     Resume HTMLTable2tbl_Exit  
      
End Function  
  Import danych z Arkuszy Kaluklacyjnych Google. Google API dot. Google SpreadSheets i interpretacja zwracaych przez Query.setResponse wyników.
Teraz przykład :-) a w przykładzie import danych z tabeli HTML jednak tabela ta będzie tworzona z Arkusza Google SpreadSheet  
Pisałem już swojego czasu przykład importu danych z takiego Arkusza. W dzisiejszym przykładzie również wykorzystam tamten  
plik. Zmieni się jednak struktura zapytania otwierająca ciekawe możliwości importu o których chciałem napisać.  
 
W poprzednim artykule importowałem do Excela dane zwracane przez zapytanie poprzez wydobywanie ich z dość niewygodnego  
formatu. Sposób działał ale do elegancji raczej mu trochu brakowało. Dziś dołożę do zapytania tylko jeden parametr: tqx=out:html  
a w efekcie dostanę tabelę HTML z której importować mogę w.w funkcją HTMLTable2tbl  :-P  
 
Sub Start1()  
    Const DocKey As String = "0At5I98HJAddmdGNwZEJIc3ZNRE4yUjdBVnRrSWt2SlE"  
    Const strArkName As String = "Arkusz1"  
    Const rngAddress As String = "A1:B5"
 
                  
    Dim strURL As String  
    strURL = "https://spreadsheets.google.com/" & _  
                    "tq?" & _  
                    "sheet=" & strArkName & "&" & _  
                    "range=" & rngAddress & "&" & _  
                    "key=" & DocKey & "&" & _  
                    "tqx=out:html"  
 
    Dim tbl: tbl = HTMLTable2tbl(strURL)  
    If Not IsArray(tbl) Then Exit Sub  
      
    With [A1]  
        .Resize(UBound(tbl), UBound(tbl, 2)) = tbl  
        .CurrentRegion.Columns.EntireColumn.AutoFit  
    End With  
End Sub  
 
Jest jeszcze jedna super mozliwość importowania danych z Arkuszy Googl'a. Można mianowicie posługiwać się SQL'em.  
Małą uwagę muszę zwrócić na fakt ze Treść zapytania trzeba zmienić na funkcją encodeURIComponent kodując znaki specjalne.  
 
 
Sub Start2()  
    Const DocKey As String = "0At5I98HJAddmdGNwZEJIc3ZNRE4yUjdBVnRrSWt2SlE"  
      
    'Query Language Reference (Version 0.7)   Query Language Reference (Version 0.7)
    'https://developers.google.com/chart/interactive/docs/querylanguage?hl=pl  
 
    Const strSQL As String = "SELECT A, sum(B) " & _
 
                             "GROUP BY A " & _  
                             "PIVOT dayOfWeek(C)"  
    Dim strURL As String  
      
    strURL = "http://spreadsheets.google.com/" & _  
                     "tq?" & _  
                     "key=" & DocKey & "&" & _   tu było o funkcji Encode
                     "tq=" & Encode(strSQL) & "&" & _   JSON (JavaScript Object Notation) na usługach Excela
                     "tqx=out:html"  
 
    Dim tbl: tbl = HTMLTable2tbl(strURL)  
    If Not IsArray(tbl) Then Exit Sub  
      
    With [A1]  
        .Resize(UBound(tbl), UBound(tbl, 2)) = tbl  
        .CurrentRegion.Columns.EntireColumn.AutoFit  
    End With  
      
End Sub