VBA / 抓取網路 JSON資料

文章索引

Post Views: 1,954

VBA無法像 JavaScript等程式有現成的編譯函數

所以處理的方式會有點瑣碎，資料必須進行多次的切割

我參考了之前東吳VBA課程吳老師的教學範例

修改成使用XMLHTTP 物件來抓取網頁資料，而不是先將資料存在儲存格中

這是因為一個儲存格中僅能顯示32,767 個字元，如果資料量太多就無法先存在儲存格

只能將資料存在變數之中，再透過字串分割處理來留下需要的資料

使用XMLHTTP 物件必須額外引入Microsoft HTML Object Library

引用物件的方式分為2種

Early Binding 和 Late Binding

Early Binding 就是先在工具->設定引用項目->勾選

之後用 New 物件名稱來建立物件

如果要控制 IE 或者 Windows系統和檔案，也同樣需要引入對應的物件

Late Binding 則是透過CreateObject(物件名稱)

用來練習的檔案都來自政府資料開放平臺

但是這個平臺只是匯集政府各單位的資料

所以不同的單位可能會有不一樣的Json內容

有些是很單純的資料，

有些還會有很多說明資訊，而資料是其中一個屬性內容，例如以下的資料

所以必須針對不同資料型態適當修改程式

'設定網址
Const URl As String = "https://data.epa.gov.tw/api/v1/aqx_p_432?limit=1000&api_key=9be7b239-557b-4c10-9775-78cadfc555e9&format=json"

'分割單筆json資料 {"key1":"value1",....}
Sub JSON_Split_Range(S, k)
     '處理資料
    'Debug.Print "S1-" & S
    S = Replace(S, """", "")
    'Debug.Print "S2-" & S
    S = Replace(S, " ", "")
    'Debug.Print "S3-" & S
    '分割單筆json資料為 key1:value1......
    arr = Split(Mid(S, 2, Len(S) - 2), ",")   '第一筆跳過{ 開始取字串 第二筆之後跳過 , 得到 key:value格式的字串陣列
    'Debug.Print "arr(0)-" & arr(0)
    c = 1
    For i = 0 To UBound(arr)
        'Debug.Print "arr(i)" & arr(i)
        '分割 key1:value1
        arr2 = Split(Trim(arr(i)), ":")
        'Debug.Print "arr2(0)" & arr2(0)
        'Debug.Print "arr2(1)" & arr2(1)
        
        If k = 1 Then
            'Debug.Print " arr2(0)-"& arr2(0)
            'Debug.Print " arr2(1)-"& arr2(1)
            Cells(k, c) = arr2(0)
            Cells(k + 1, c) = arr2(1)
        Else: Cells(k + 1, c) = arr2(1)
        End If
        c = c + 1
    Next
End Sub

'透過XMLHTTP 抓取網頁資料
Sub xmlHttp()
    
    Application.ScreenUpdating = False
    '刪除舊資料
    Sheets(1).Select
    Cells.Select
    Selection.ClearContents
    Range("A1").Select
    
     '設定 XMLHTTP 物件
    Dim xmlHttp As Object
    Set xmlHttp = CreateObject("MSXML2.ServerXMLHTTP.6.0")
    xmlHttp.Open "GET", URl, False
    xmlHttp.setRequestHeader "Content-Type", "application/json ; charset=utf-8"
    xmlHttp.setRequestHeader "Cache-Control", "no-cache"
    xmlHttp.setRequestHeader "Pragma", "no-cache"
    xmlHttp.setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/90.0.4430.212 Safari/537.36"
    xmlHttp.send
    
    '儲存格內容的長度 (文字)
    '32,767 個字元。在一個儲存格中僅能顯示1,024 個字元；在資料編輯列顯示全部 32,767 個字元。

    'XMLHttp Response
    'T = xmlHttp.getResponseHeader("content-length") '資料字元數
    'P = Len(xmlHttp.ResponseText)                   '資料內容長度
    
    S = xmlHttp.ResponseText                         '回傳資料內容
    
    '連線沒問題才處理
    If xmlHttp.readyState = 4 Then
        If xmlHttp.Status = 200 Then
            
            '處理抓回來的資料  要依據實際資料進行調整
            
            startVal = InStr(1, S, """" & "records" & """", vbTextCompare) ' "records"
            startVal = InStr(startVal, S, "[", vbTextCompare)  '[
            endVal = InStr(startVal, S, "]", vbTextCompare)    ']
            strDiv = Mid(S, startVal, (endVal - startVal) + 1) '從"records" 後取出[{...}]
            'Debug.Print "strDiv-" & strDiv
            
            'Debug.Print "Mid(strDiv, 2, Len(strDiv) - 2" & Mid(strDiv, 2, Len(strDiv) - 2) '從[...]取出 {..).{..}  -
            arr = Split(Mid(strDiv, 2, Len(strDiv) - 2), "}")       '>split }  最後一個分割 會沒有資料

            k = 1
            'Debug.Print "UBound(arr)-" &UBound(arr)
            For i = 0 To UBound(arr) '回傳陣列的index數
                'Debug.Print "arr(i)-" & arr(i)
                If arr(i) <> "" Then                 '最後一筆分割沒資料
                    Call JSON_Split_Range(arr(i), k) '再分割
                End If
                k = k + 1
            Next
            
        End If
    End If
    MsgBox ("輸出完成")
    Application.ScreenUpdating = True
   
 End Sub