Import chuỗi JSON vào Excel

Liên hệ QC
Trước tiên ta cần hiểu sơ qua chuỗi JSON là gì nhé!
Thông thường lập trình web người ta sẽ liên kết dữ liệu vào một hệ quản trị cơ sở dữ liệu. Hệ quản trị này phải được cài đặt trước (MySQL chẳng hạn)
Với những CSDL dạng nhỏ, để tránh phiền phức về việc cài đặt chương trình, người ta muốn "ăn ngay" bằng cách chuyển đổi CSDL thành dạng chuỗi theo cấu trúc nào đó. Khi download về máy tính, ta lại giải mã cấu trúc chuỗi này để nhận được dữ liệu hoàn chỉnh
Chuỗi JSON chính là cái chuỗi có cấu trúc đặt biệt như tôi nói ở trên. Thêm nữa là hiện nay JSON hỗ trợ hầu hết các ngôn ngữ lập trình (vì thực chất cấu trúc này chỉ là dạng chuỗi)
----------------------------------
Tôi giả định rằng ông lập trình viên web giao cho tôi đường link như sau:
http://warehouse.bigapptech.com.vn/api/material/get
Ông ấy nói rằng đường link này sẽ trả về một chuỗi JSON. Tôi gõ link trên vào trình duyệt và nhận được kết quả

Capture1.JPG

hoặc:

Capture2.JPG


tùy theo cách hiển thị của trình duyệt (Firefox cho phép hiển thị theo 2 kiểu)
-------------------
Giờ tôi sẽ tiến hành viết code để 1> Download chuỗi JSON, 2> Biến đổi chuỗi JSON thành dữ liệu trên Excel

Mã:
Public Const URL = "http://warehouse.bigapptech.com.vn/api/material/get"
Dim data, total
Function DownloadJSON(ByVal sURL As String) As Object
  Dim objHTTP   As Object
  Dim objScript As Object
  Set objScript = CreateObject("MSScriptControl.ScriptControl")
  objScript.Language = "JScript"
  Set objHTTP = CreateObject("MSXML2.XMLHTTP")
  On Error Resume Next
  With objHTTP
    .Open "GET", sURL, False
    .send
    Set DownloadJSON = objScript.Eval("(" & .responseText & ")")
    .abort
  End With
  Set objHTTP = Nothing: Set objScript = Nothing
End Function
Function GetBigAppTech(ByVal JSON As Object)
  Dim jsData    As Object
  Dim jsItem    As Object
  Dim lCount    As Long
  Dim idx       As Long
  On Error Resume Next
  If JSON Is Nothing Then Exit Function
  Set jsData = JSON.data
  lCount = JSON.total
  ReDim aRes(1 To lCount, 1 To 3)
  For Each jsItem In jsData
    idx = idx + 1
    aRes(idx, 1) = jsItem.material_id
    aRes(idx, 2) = jsItem.material_name
    aRes(idx, 3) = jsItem.material_inventory
  Next
  If idx Then GetBigAppTech = aRes
  Set jsData = Nothing: Set jsItem = Nothing
End Function
Sub Test()
  Dim aRes, JSON As Object
  Set JSON = DownloadJSON(URL)
  If JSON Is Nothing Then
    MsgBox "Please check the status of Network!"
    Exit Sub
  End If
  aRes = GetBigAppTech(JSON)
  If IsArray(aRes) Then
    Range("A1:C1").Resize(UBound(aRes)).Value = aRes
    MsgBox "Done!"
  End If
End Sub

Code chạy tốt nhưng có 3 vấn đề xuất hiện:
1> Các bạn để ý câu lệnh Set jsData = JSON.data, ngay khi gõ xong thì chắc chắn chữ data sẽ bị biến thành Data (viết HOA ký tự "D"). Ác cái code này có phân biệt HOA thường nên sẽ bị lỗi (dòng thứ 2 trong kết quả trên trình duyệt là data chứ không phải Data). Tôi đang chơi "ăn gian" bằng cách khai báo biến data trên đầu code (mà chẳng để làm gì)
2> Cũng câu lệnh trên Set jsData = JSON.data, ý tôi là muốn lấy dữ liệu từ nhánh data. Trong trường hợp tôi muốn viết code theo cách tổng quát hơn:
Mã:
Function GetBigAppTech(ByVal JSON As Object, byVal sProperty as String)
....................
End Function
thì cái đối số sProperty trong hàm sẽ được truyền như thế nào cho câu lệnh trên (ở đây tôi muốn truyền sProperty = "data")
3> Tôi có câu lệnh:
Mã:
 lCount = JSON.total
  ReDim aRes(1 To lCount, 1 To 3)
là vì may mắn chuỗi JSON trả về có đoạn total: 5 nên từ đây tôi biết được dữ liệu có 5 dòng. Đặt trường hợp chuỗi JSON này không có dòng total: 5 như trên thì bằng cách nào tôi biết được phải khai báo chiều thứ nhất cho mảng aRes bao nhiêu là đủ?
--------------------------
Đang tập tành nên còn nhiều thứ chưa biết nên nhận được sự góp ý từ các bạn. Xin cảm ơn
(thật ra trên mạng có cả 1 thư việc viết sẵn để xử lý nhưng dài quá, trong khi tôi muốn tự mình xây dựng lấy ứng dụng)
 

File đính kèm

  • GetJSData.xlsm
    47.9 KB · Đọc: 89
Trước tiên ta cần hiểu sơ qua chuỗi JSON là gì nhé!
Thông thường lập trình web người ta sẽ liên kết dữ liệu vào một hệ quản trị cơ sở dữ liệu. Hệ quản trị này phải được cài đặt trước (MySQL chẳng hạn)
Với những CSDL dạng nhỏ, để tránh phiền phức về việc cài đặt chương trình, người ta muốn "ăn ngay" bằng cách chuyển đổi CSDL thành dạng chuỗi theo cấu trúc nào đó. Khi download về máy tính, ta lại giải mã cấu trúc chuỗi này để nhận được dữ liệu hoàn chỉnh
Chuỗi JSON chính là cái chuỗi có cấu trúc đặt biệt như tôi nói ở trên. Thêm nữa là hiện nay JSON hỗ trợ hầu hết các ngôn ngữ lập trình (vì thực chất cấu trúc này chỉ là dạng chuỗi)
----------------------------------
Tôi giả định rằng ông lập trình viên web giao cho tôi đường link như sau:
http://warehouse.bigapptech.com.vn/api/material/get
Ông ấy nói rằng đường link này sẽ trả về một chuỗi JSON. Tôi gõ link trên vào trình duyệt và nhận được kết quả

View attachment 196700

hoặc:

View attachment 196701


tùy theo cách hiển thị của trình duyệt (Firefox cho phép hiển thị theo 2 kiểu)
-------------------
Giờ tôi sẽ tiến hành viết code để 1> Download chuỗi JSON, 2> Biến đổi chuỗi JSON thành dữ liệu trên Excel

Mã:
Public Const URL = "http://warehouse.bigapptech.com.vn/api/material/get"
Dim data, total
Function DownloadJSON(ByVal sURL As String) As Object
  Dim objHTTP   As Object
  Dim objScript As Object
  Set objScript = CreateObject("MSScriptControl.ScriptControl")
  objScript.Language = "JScript"
  Set objHTTP = CreateObject("MSXML2.XMLHTTP")
  On Error Resume Next
  With objHTTP
    .Open "GET", sURL, False
    .send
    Set DownloadJSON = objScript.Eval("(" & .responseText & ")")
    .abort
  End With
  Set objHTTP = Nothing: Set objScript = Nothing
End Function
Function GetBigAppTech(ByVal JSON As Object)
  Dim jsData    As Object
  Dim jsItem    As Object
  Dim lCount    As Long
  Dim idx       As Long
  On Error Resume Next
  If JSON Is Nothing Then Exit Function
  Set jsData = JSON.data
  lCount = JSON.total
  ReDim aRes(1 To lCount, 1 To 3)
  For Each jsItem In jsData
    idx = idx + 1
    aRes(idx, 1) = jsItem.material_id
    aRes(idx, 2) = jsItem.material_name
    aRes(idx, 3) = jsItem.material_inventory
  Next
  If idx Then GetBigAppTech = aRes
  Set jsData = Nothing: Set jsItem = Nothing
End Function
Sub Test()
  Dim aRes, JSON As Object
  Set JSON = DownloadJSON(URL)
  If JSON Is Nothing Then
    MsgBox "Please check the status of Network!"
    Exit Sub
  End If
  aRes = GetBigAppTech(JSON)
  If IsArray(aRes) Then
    Range("A1:C1").Resize(UBound(aRes)).Value = aRes
    MsgBox "Done!"
  End If
End Sub

Code chạy tốt nhưng có 3 vấn đề xuất hiện:
1> Các bạn để ý câu lệnh Set jsData = JSON.data, ngay khi gõ xong thì chắc chắn chữ data sẽ bị biến thành Data (viết HOA ký tự "D"). Ác cái code này có phân biệt HOA thường nên sẽ bị lỗi (dòng thứ 2 trong kết quả trên trình duyệt là data chứ không phải Data). Tôi đang chơi "ăn gian" bằng cách khai báo biến data trên đầu code (mà chẳng để làm gì)
2> Cũng câu lệnh trên Set jsData = JSON.data, ý tôi là muốn lấy dữ liệu từ nhánh data. Trong trường hợp tôi muốn viết code theo cách tổng quát hơn:
Mã:
Function GetBigAppTech(ByVal JSON As Object, byVal sProperty as String)
....................
End Function
thì cái đối số sProperty trong hàm sẽ được truyền như thế nào cho câu lệnh trên (ở đây tôi muốn truyền sProperty = "data")
3> Tôi có câu lệnh:
Mã:
lCount = JSON.total
  ReDim aRes(1 To lCount, 1 To 3)
là vì may mắn chuỗi JSON trả về có đoạn total: 5 nên từ đây tôi biết được dữ liệu có 5 dòng. Đặt trường hợp chuỗi JSON này không có dòng total: 5 như trên thì bằng cách nào tôi biết được phải khai báo chiều thứ nhất cho mảng aRes bao nhiêu là đủ?
--------------------------
Đang tập tành nên còn nhiều thứ chưa biết nên nhận được sự góp ý từ các bạn. Xin cảm ơn
(thật ra trên mạng có cả 1 thư việc viết sẵn để xử lý nhưng dài quá, trong khi tôi muốn tự mình xây dựng lấy ứng dụng)
Trong đoạn code:
With objHTTP
.....
End with
Tôi chưa thử nhưng có thể xác định lCount như vầy cho trường hợp 3:
lCount=(Len(.responseText) - Len(Replace(.responseText, "material_id", ""))) / Len("material_id")
Còn 2 trường hợp trên nếu thì không biết, nếu là tôi thì sẽ dùng Regexp để xử lý chuỗi Json này.
 
Trong đoạn code:
With objHTTP
.....
End with
Tôi chưa thử nhưng có thể xác định lCount như vầy cho trường hợp 3:
lCount=(Len(.responseText) - Len(Replace(.responseText, "material_id", ""))) / Len("material_id")
Còn 2 trường hợp trên nếu thì không biết, nếu là tôi thì sẽ dùng Regexp để xử lý chuỗi Json này.
tôi quên không nói rằng: Nếu chỉ xử lý text thông thường thì có nhiều cách và tôi làm được. Ở đây tôi muốn công cụ chuyên nghiệp hơn, tức là thứ gì đó chuyên trị JSON
Đó là chưa nói đến trường hợp tổng quát: Ta chưa biết trước chuỗi JSON chứa gì trong đó, tức ta chưa có cái "material_id" trong tay. Vậy nếu yêu cầu xuất toàn bộ JSON ra excel table thì ta làm cách nào?
 
Ủa rồi xài cái này trên máy 64 bit làm sao đây anh đẹp chai ? chuyên nghiệp là ở đâu cũng phải chạy được nhá :D

Máy mình không có cái ScriptControl nên không biết thử, nhưng chém gió chắc vẫn ổn.
Mình thấy có mấy đường dẫn này không biết có giúp ích gì cho anh đẹp chai ?

https://stackoverflow.com/questions/6627652/parsing-json-in-excel-vba

Lưu ý cái thứ trả về từ jsonObj[propertyName] rất nhạy cảm, có khi là 1 chuỗi, có khi là 1 jsonobject con, anh có máy thì thử.

và đây cũng có đoạn nói về dung lượng của 1 object trong javascript, có thể thử xài jsonObj[propertyName].length xem sao, nếu thất bại đừng trách mình, mình không có công cụ "chuyên nghiệp xử lý JSON"

https://stackoverflow.com/questions/5861536/getting-the-size-of-an-array-in-an-object
 
Ủa rồi xài cái này trên máy 64 bit làm sao đây anh đẹp chai ? chuyên nghiệp là ở đâu cũng phải chạy được nhá :D

Máy mình không có cái ScriptControl nên không biết thử, nhưng chém gió chắc vẫn ổn.
Mình thấy có mấy đường dẫn này không biết có giúp ích gì cho anh đẹp chai ?

https://stackoverflow.com/questions/6627652/parsing-json-in-excel-vba

Lưu ý cái thứ trả về từ jsonObj[propertyName] rất nhạy cảm, có khi là 1 chuỗi, có khi là 1 jsonobject con, anh có máy thì thử.
Thật ra là mình có xem qua, cũng dò "nát" cả google mấy ngày rồi, chỉ vì chưa "tiêu hóa" kịp thôi
--------------------------------------------
và đây cũng có đoạn nói về dung lượng của 1 object trong javascript, có thể thử xài jsonObj[propertyName].length xem sao, nếu thất bại đừng trách mình, mình không có công cụ "chuyên nghiệp xử lý JSON"

https://stackoverflow.com/questions/5861536/getting-the-size-of-an-array-in-an-object
Chỗ này thì đúng là mình chưa để ý. Hay quá bạn ơi!
Như file bài 1, thêm câu lệnh MsgBox DownloadJSON.data.length cho kết quả =5 ---> Ngon
Có điều vẫn còn tồn tại vấn đề 1 như mình nêu ở trên: có vẻ như mấy từ id, data, length.... là từ khóa của Excel hay sao ấy, cứ gõ phát nó tự ProperCase, thế là code lỗi. Chỗ này mình chẳng biết xử sao cho đúng (ngoài cách tạo biến tào lao ở đầu code mà không dùng vào việc gì)
 
Thật ra là mình có xem qua, cũng dò "nát" cả google mấy ngày rồi, chỉ vì chưa "tiêu hóa" kịp thôi
--------------------------------------------

Chỗ này thì đúng là mình chưa để ý. Hay quá bạn ơi!
Như file bài 1, thêm câu lệnh MsgBox DownloadJSON.data.length cho kết quả =5 ---> Ngon
Có điều vẫn còn tồn tại vấn đề 1 như mình nêu ở trên: có vẻ như mấy từ id, data, length.... là từ khóa của Excel hay sao ấy, cứ gõ phát nó tự ProperCase, thế là code lỗi. Chỗ này mình chẳng biết xử sao cho đúng (ngoài cách tạo biến tào lao ở đầu code mà không dùng vào việc gì)

ông này giỡn hoài ta ơi !

Cái đường dẫn ở trên đã bao gồm việc tạo ra những hàm tự định nghĩa cho Javascript, giúp tránh khỏi lỗi tự viết hoa của VBA rồi mà, anh có xài chưa ?

Thật ra mình không muốn viết thẳng hết code ra, âu cũng là vì nghĩ cho anh là cao thủ, có thể tự xoay sở từ đường dẫn đã có sẵn, thôi thì nếu anh chưa quen với Jscript thì tôi viết thẳng vào trong file đưa lên vậy, anh đừng ngại nhá.
 

File đính kèm

  • GetJSData.xlsm
    46.2 KB · Đọc: 80
Có điều vẫn còn tồn tại vấn đề 1 như mình nêu ở trên: có vẻ như mấy từ id, data, length.... là từ khóa của Excel hay sao ấy, cứ gõ phát nó tự ProperCase, thế là code lỗi. Chỗ này mình chẳng biết xử sao cho đúng (ngoài cách tạo biến tào lao ở đầu code mà không dùng vào việc gì)
Chắc phải chơi kiểu khác quá:
Mã:
Public Function GetProperty(ByVal jsObject As Object, ByVal PropertyName As String)
  GetProperty = objScript.Run("getProperty", jsObject, PropertyName)
End Function

Mã:
lCount = GetProperty(jsObject, "length")
Là khỏi sợ vụ ProperCase
 
ông này giỡn hoài ta ơi !

Cái đường dẫn ở trên đã bao gồm việc tạo ra những hàm tự định nghĩa cho Javascript, giúp tránh khỏi lỗi tự viết hoa của VBA rồi mà, anh có xài chưa ?

Thật ra mình không muốn viết thẳng hết code ra, âu cũng là vì nghĩ cho anh là cao thủ, có thể tự xoay sở từ đường dẫn đã có sẵn, thôi thì nếu anh chưa quen với Jscript thì tôi viết thẳng vào trong file đưa lên vậy, anh đừng ngại nhá.
Đúng là chưa quen nên trong lúc hỏi mình lại... mò mò. Cuối cùng cũng vừa xong. Cảm ơn bạn nhiều nhé
 
Đúng là chưa quen nên trong lúc hỏi mình lại... mò mò. Cuối cùng cũng vừa xong. Cảm ơn bạn nhiều nhé
Em vọc cái thằng JSON này cũng bầm dập, nhưng đến nay vẫn chưa đâu vào đâu. Dữ liệu để em vọc thì là Firebase, từ google sheet có thể thêm sửa xóa dữ liệu từ firebase.
Còn ở Excel thì chưa thử, nhưng Sư Phụ có thể test code bên dưới coi như thế nào nhé.

JSON:
Sub test_JSON()
    Dim json As String
    Dim d, i, dong
    With CreateObject("MSXML2.XMLHTTP")
        .Open "GET", "http://warehouse.bigapptech.com.vn/api/material/get", False
        .send
        json = .responseText
    End With
    With CreateObject("scriptcontrol")
        .Language = "JScript"
        .Eval "var obj=(" & json & ")"
        .AddCode "function demDong(){return obj.data.length;}"
        .AddCode "function layDL(i){var d=obj.data[i];" & _
                 "return {m_id:d.material_id,m_name:d.material_name," & _
                 "m_unit:d.material_unit,m_stock:d.material_opening_stock,m_weight:d.material_weight};}"
        dong = .Run("demDong")
        Debug.Print ""
        Debug.Print "Tong:", dong & "dòng"
        For i = 0 To dong - 1
            Set d = .Run("layDL", i)
            Debug.Print d.m_id, d.m_name, d.m_unit, d.m_stock, d.m_weight
        Next
    End With
End Sub
 
Em vọc cái thằng JSON này cũng bầm dập, nhưng đến nay vẫn chưa đâu vào đâu. Dữ liệu để em vọc thì là Firebase, từ google sheet có thể thêm sửa xóa dữ liệu từ firebase.
Còn ở Excel thì chưa thử, nhưng Sư Phụ có thể test code bên dưới coi như thế nào nhé.

JSON:
Sub test_JSON()
    Dim json As String
    Dim d, i, dong
    With CreateObject("MSXML2.XMLHTTP")
        .Open "GET", "http://warehouse.bigapptech.com.vn/api/material/get", False
        .send
        json = .responseText
    End With
    With CreateObject("scriptcontrol")
        .Language = "JScript"
        .Eval "var obj=(" & json & ")"
        .AddCode "function demDong(){return obj.data.length;}"
        .AddCode "function layDL(i){var d=obj.data[i];" & _
                 "return {m_id:d.material_id,m_name:d.material_name," & _
                 "m_unit:d.material_unit,m_stock:d.material_opening_stock,m_weight:d.material_weight};}"
        dong = .Run("demDong")
        Debug.Print ""
        Debug.Print "Tong:", num & "dòng"
        For i = 0 To dong - 1
            Set d = .Run("layDL", i)
            Debug.Print d.m_id, d.m_name, d.m_unit, d.m_stock, d.m_weight
        Next
    End With
End Sub
Code cuối cùng của tôi:
Mã:
Option Explicit
Public objScript    As Object
Public objHTTP      As Object
Private Const URL1  As String = "http://warehouse.bigapptech.com.vn/api/material/get"
Private Const URL2  As String = "https://syndication.redplum.com/kilgore/StandardSyndicationPartner/offers/?provider=thor&filterByZipCode=77477&filterByLoyaltyProgram=all"
Private Sub Initialize()
  Set objScript = CreateObject("MSScriptControl.ScriptControl")
  Set objHTTP = CreateObject("MSXML2.XMLHTTP")
  With objScript
    .Language = "JScript"
    .AddCode "function getProperty(jsonObj, propertyName) { return jsonObj[propertyName]; } "
    .AddCode "function getKeys(jsonObj) { var keys = new Array(); for (var i in jsonObj) { keys.push(i); } return keys; } "
  End With
End Sub
Public Function DecodeJson(ByVal jsString As String)
  Set DecodeJson = objScript.Eval("(" & jsString & ")")
End Function
Public Function DownloadJson(ByVal sURL As String) As String
  With objHTTP
    .Open "GET", sURL, False
    .Send
     DownloadJson = .responseText
  End With
End Function
Public Function GetProperty(ByVal jsObject As Object, ByVal PropertyName As String)
  GetProperty = objScript.Run("getProperty", jsObject, PropertyName)
End Function
Public Function GetObjectProperty(ByVal jsObject As Object, ByVal PropertyName As String) As Object
  Set GetObjectProperty = objScript.Run("getProperty", jsObject, PropertyName)
End Function
Public Sub TestJSON2Table1()
  Dim jsString      As String
  Dim jsObject      As Object
  Dim jsKeysObject  As Object
  Dim jsItemObject  As Object
  Dim jsKey         As Variant
  Dim lRow          As Long
  Dim lCount        As Long
  
  If objScript Is Nothing Then Initialize
  jsString = DownloadJson(URL1)
  Set jsObject = DecodeJson(CStr(jsString))
  Set jsObject = GetObjectProperty(jsObject, "data")
  lCount = GetProperty(jsObject, "length")
  Set jsKeysObject = objScript.Run("getKeys", jsObject)
  ReDim aRes(1 To lCount, 1 To 4)

  For Each jsKey In jsKeysObject
    Set jsItemObject = GetObjectProperty(jsObject, jsKey)
    lRow = lRow + 1
    aRes(lRow, 1) = lRow
    aRes(lRow, 2) = GetProperty(jsItemObject, "material_id")
    aRes(lRow, 3) = GetProperty(jsItemObject, "material_name")
    aRes(lRow, 4) = GetProperty(jsItemObject, "material_inventory")
  Next
  
  Sheet1.Range("A:D").ClearContents
  Sheet1.Range("A1:D1").Resize(lRow).Value = aRes
End Sub
Public Sub TestJSON2Table2()
  Dim jsString      As String
  Dim jsObject      As Object
  Dim jsKeysObject  As Object
  Dim jsItemObject  As Object
  Dim jsKey         As Variant
  Dim lRow          As Long
  Dim lCount        As Long
  
  If objScript Is Nothing Then Initialize
  jsString = DownloadJson(URL2)
  Set jsObject = DecodeJson(CStr(jsString))
  Set jsObject = GetObjectProperty(jsObject, "payload")
  lCount = GetProperty(jsObject, "length")
  Set jsKeysObject = objScript.Run("getKeys", jsObject)
  ReDim aRes(1 To lCount, 1 To 6)

  For Each jsKey In jsKeysObject
    Set jsItemObject = GetObjectProperty(jsObject, jsKey)
    lRow = lRow + 1
    aRes(lRow, 1) = lRow
    aRes(lRow, 2) = GetProperty(jsItemObject, "displayName")
    aRes(lRow, 3) = GetProperty(jsItemObject, "purchaseDescription")
    aRes(lRow, 4) = GetProperty(jsItemObject, "savingsValueStatement")
    aRes(lRow, 5) = GetProperty(jsItemObject, "displayValue")
    aRes(lRow, 6) = GetProperty(jsItemObject, "valassisOfferId")
  Next
  Sheet2.Range("A:F").ClearContents
  Sheet2.Range("A1:F1").Resize(lRow).Value = aRes
End Sub
Cải tiến lại vì code trên mạng chạy đến 2 vòng lập (mà tôi thấy nó thừa)
Chia ra từng hàm riêng biệt, tiện cho việc xử lý những bài toán khác
(2 sheet test thử lấy dữ liệu từ 2 URL khác nhau)
 

File đính kèm

  • GetJSData2.xlsm
    55.2 KB · Đọc: 58
ông này giỡn hoài ta ơi !
...
Thật ra mình không muốn viết thẳng hết code ra, âu cũng là vì nghĩ cho anh là cao thủ, có thể tự xoay sở từ đường dẫn đã có sẵn, thôi thì nếu anh chưa quen với Jscript thì tôi viết thẳng vào trong file đưa lên vậy, anh đừng ngại nhá.
Dân VB/VBA bây giờ qua giang sơn JavaScript thì cái "learning curve" nó hơi dốc.
Tôi nghĩ nó đòi hỏi sự suy nghĩ bắt nguồn lại từ đầu. Cũng như đang chơi Windows mà bước qua Linux vậy.

(Mà vô cái màn này thì lọt trúng giang sơn của "em" rồi nhỉ. Tha hồ mà vẽ voi, cả diễn đàn này vô đối thủ.)
 
Code cũ viết đơn giản nhưng mà tốc độ nhanh còn code mới viết tổng quát thì lại chậm thấy rõ.
Có vẻ như gọi thông qua Property dạng String nó bị chậm thì phải???
Lại nghiên cứu tiếp thôi
 
Code cũ viết đơn giản nhưng mà tốc độ nhanh còn code mới viết tổng quát thì lại chậm thấy rõ.
Có vẻ như gọi thông qua Property dạng String nó bị chậm thì phải???
Lại nghiên cứu tiếp thôi

Mình có ngồi thử máy 32 bit thấy khi khởi tạo đối tượng ScriptControl lần đầu thì chậm chứ mấy lần chạy sau đâu có chậm, không biết ý anh là chậm vì cái gì ? hay là anh thử chạy vòng lặp trong code Jscript để phân tách data object cho trả về mảng luôn thử xem có được chăng ? (chưa thử, mới ý tưởng thôi, khi nào "mượn" được máy mới tính được).
 
Dân VB/VBA bây giờ qua giang sơn JavaScript thì cái "learning curve" nó hơi dốc.
Tôi nghĩ nó đòi hỏi sự suy nghĩ bắt nguồn lại từ đầu. Cũng như đang chơi Windows mà bước qua Linux vậy.

(Mà vô cái màn này thì lọt trúng giang sơn của "em" rồi nhỉ. Tha hồ mà vẽ voi, cả diễn đàn này vô đối thủ.)

Em không biết gì mấy cái Jscript này hết, có việc thì làm thôi. Em chỉ giỏi dùng độc thôi (đã có người khen "bông hoa đẹp mà toàn chất độc").
 
Mình có ngồi thử máy 32 bit thấy khi khởi tạo đối tượng ScriptControl lần đầu thì chậm chứ mấy lần chạy sau đâu có chậm, không biết ý anh là chậm vì cái gì ? hay là anh thử chạy vòng lặp trong code Jscript để phân tách data object cho trả về mảng luôn thử xem có được chăng ? (chưa thử, mới ý tưởng thôi, khi nào "mượn" được máy mới tính được).
Có lẽ máy tính tôi cùi bắp nên cảm nhận sự khác biệt về tốc độ rất rõ
Bạn có thể code tôi viết theo phong cách của bài 1:
Mã:
Dim data, displayName, length
Public objScript    As Object
Public objHTTP      As Object
Private Const URL1  As String = "http://warehouse.bigapptech.com.vn/api/material/get"
Private Const URL2  As String = "https://syndication.redplum.com/kilgore/StandardSyndicationPartner/offers/?provider=thor&filterByZipCode=77477&filterByLoyaltyProgram=all"
Public Sub Initialize()
  Set objScript = CreateObject("MSScriptControl.ScriptControl")
  Set objHTTP = CreateObject("MSXML2.XMLHTTP")
  objScript.Language = "JScript"
End Sub
Public Function DownloadJson(ByVal strURL As String) As String
  With objHTTP
    .Open "GET", strURL, False
    .Send
     DownloadJson = .responseText
  End With
End Function
Public Function DecodeJson(ByVal jsString As String) As Object
  Set DecodeJson = objScript.Eval("(" & jsString & ")")
End Function
Sub Test1()
  Dim jsObject  As Object
  Dim jsItem    As Object
  Dim jsString  As String
  Dim lCount    As Long
  Dim lRow       As Long
  
  If objHTTP Is Nothing Then Initialize
  jsString = DownloadJson(URL1)
  Set jsObject = DecodeJson(jsString)
  If jsObject Is Nothing Then
    MsgBox "Please check the status of Network!"
  Else
    Set jsObject = jsObject.data
    lCount = jsObject.length
    ReDim aRes(1 To lCount, 1 To 4)
    For Each jsItem In jsObject
      lRow = lRow + 1
      aRes(lRow, 1) = lRow
      aRes(lRow, 2) = jsItem.material_id
      aRes(lRow, 3) = jsItem.material_name
      aRes(lRow, 4) = jsItem.material_inventory
    Next
    Range("A:F").ClearContents
    Range("A1:D1").Resize(UBound(aRes)).Value = aRes
    MsgBox "Done!"
  End If
End Sub
Sub Test2()
  Dim jsObject  As Object
  Dim jsItem    As Object
  Dim jsString  As String
  Dim lCount    As Long
  Dim lRow       As Long
  
  If objHTTP Is Nothing Then Initialize
  jsString = DownloadJson(URL2)
  Set jsObject = DecodeJson(jsString)
  If jsObject Is Nothing Then
    MsgBox "Please check the status of Network!"
  Else
    Set jsObject = jsObject.payload
    lCount = jsObject.length
    ReDim aRes(1 To lCount, 1 To 6)
    For Each jsItem In jsObject
      lRow = lRow + 1
      aRes(lRow, 1) = lRow
      aRes(lRow, 2) = jsItem.displayName
      aRes(lRow, 3) = jsItem.purchaseDescription
      aRes(lRow, 4) = jsItem.savingsValueStatement
      aRes(lRow, 5) = jsItem.displayValue
      aRes(lRow, 6) = jsItem.valassisOfferId
    Next
    Range("A:F").ClearContents
    Range("A1:F1").Resize(UBound(aRes)).Value = aRes
    MsgBox "Done!"
  End If
End Sub
Chạy Sub Test2 bài này và so sánh tốc độ với Sub Test2 ở bài #10 sẽ có sự khác biệt rất lớn, nhất là khi chạy code trên máy cấu hình yếu
 
Mình có ngồi thử máy 32 bit thấy khi khởi tạo đối tượng ScriptControl lần đầu thì chậm chứ mấy lần chạy sau đâu có chậm, không biết ý anh là chậm vì cái gì ? hay là anh thử chạy vòng lặp trong code Jscript để phân tách data object cho trả về mảng luôn thử xem có được chăng ? (chưa thử, mới ý tưởng thôi, khi nào "mượn" được máy mới tính được).
Gọi objects từ nơi khác thì phải biết luật này. Lần đầu tiên thì hệ thống phải nạp engine vào bộ nhớ. Mấy lần sau thì có sẵn, khỏi phải nạp - trừ phi code có cái gì ăn bộ nhớ quá thì nó lại bị đẩy ra.
Thử tốc độ thì ngừoi ta thử cả chục lượt chứ chơi 1 cái thì hơi tay mơ.
 
Có lẽ máy tính tôi cùi bắp nên cảm nhận sự khác biệt về tốc độ rất rõ
Bạn có thể code tôi viết theo phong cách của bài 1:
Chạy Sub Test2 bài này và so sánh tốc độ với Sub Test2 ở bài #10 sẽ có sự khác biệt rất lớn, nhất là khi chạy code trên máy cấu hình yếu

Bữa nay em không còn thời gian nữa, và cũng không ai cho mượn máy để thử, Nếu anh nói chậm thì có lẽ nó chậm thật, trong đầu em chỉ dự tính thấy có vài chỗ có thể tối ưu nếu sử dụng phong cách viết hàm tự tạo cho Jscript. Theo em suy đoán thì mã Jscript không hề chậm đâu, đặc biệt là nó làm việc với JSON như 1 Object array thuần túy của Javascript, rất mạnh về tốc độ là đằng khác.
Nhưng thôi hôm nay thiên địa nhân cái gì cũng chống lại em hết, chắc để mai em coi lại cái đống này, xem ta có thể làm được gì. Anh thông cảm nhá.
 
Bữa nay em không còn thời gian nữa, và cũng không ai cho mượn máy để thử, Nếu anh nói chậm thì có lẽ nó chậm thật, trong đầu em chỉ dự tính thấy có vài chỗ có thể tối ưu nếu sử dụng phong cách viết hàm tự tạo cho Jscript. Theo em suy đoán thì mã Jscript không hề chậm đâu, đặc biệt là nó làm việc với JSON như 1 Object array thuần túy của Javascript, rất mạnh về tốc độ là đằng khác.
Nhưng thôi hôm nay thiên địa nhân cái gì cũng chống lại em hết, chắc để mai em coi lại cái đống này, xem ta có thể làm được gì. Anh thông cảm nhá.
Tôi xem kỹ lại thì thấy code trong vòng lập của mình quá ngu (không sai nhưng thừa 1 thúng khiến số lượng phép tính tăng gấp đôi). Tôi sửa lại:
Mã:
Public objScript    As Object
Public objHTTP      As Object
Private Const URL1  As String = "http://warehouse.bigapptech.com.vn/api/material/get"
Private Const URL2  As String = "https://syndication.redplum.com/kilgore/StandardSyndicationPartner/offers/?provider=thor&filterByZipCode=77477&filterByLoyaltyProgram=all"
Private Sub Initialize()
  Set objScript = CreateObject("MSScriptControl.ScriptControl")
  Set objHTTP = CreateObject("MSXML2.XMLHTTP")
  With objScript
    .Language = "JScript"
    .AddCode "function getProperty(jsonObj, propertyName) { return jsonObj[propertyName]; } "
    .AddCode "function getKeys(jsonObj) { var keys = new Array(); for (var i in jsonObj) { keys.push(i); } return keys; } "
  End With
End Sub
Public Function DecodeJson(ByVal jsString As String) As Object
  Set DecodeJson = objScript.Eval("(" & jsString & ")")
End Function
Public Function DownloadJson(ByVal sURL As String) As String
  With objHTTP
    .Open "GET", sURL, False
    .Send
     DownloadJson = .responseText
  End With
End Function
Public Function GetProperty(ByVal jsObject As Object, ByVal PropertyName As String)
  GetProperty = objScript.Run("getProperty", jsObject, PropertyName)
End Function
Public Function GetObjectProperty(ByVal jsObject As Object, ByVal PropertyName As String) As Object
  Set GetObjectProperty = objScript.Run("getProperty", jsObject, PropertyName)
End Function
Public Sub TestJSON2Table1()
  Dim jsString      As String
  Dim jsObject      As Object
  Dim jsKey         As Variant
  Dim lRow          As Long
  Dim lCount        As Long

  If objScript Is Nothing Then Initialize
  jsString = DownloadJson(URL1)
  Set jsObject = DecodeJson(CStr(jsString))
  Set jsObject = GetObjectProperty(jsObject, "data")
  lCount = GetProperty(jsObject, "length")
  ReDim aRes(1 To lCount, 1 To 4)

  For Each jsKey In jsObject
    lRow = lRow + 1
    aRes(lRow, 1) = lRow
    aRes(lRow, 2) = GetProperty(jsKey, "material_id")
    aRes(lRow, 3) = GetProperty(jsKey, "material_name")
    aRes(lRow, 4) = GetProperty(jsKey, "material_inventory")
  Next

  Sheet1.Range("A:F").ClearContents
  Sheet1.Range("A1:D1").Resize(lRow).Value = aRes
  MsgBox "Done!"
End Sub
Public Sub TestJSON2Table2()
  Dim jsString      As String
  Dim jsObject      As Object
  Dim jsKey         As Variant
  Dim lRow          As Long
  Dim lCount        As Long

  If objScript Is Nothing Then Initialize
  jsString = DownloadJson(URL2)
  Set jsObject = DecodeJson(CStr(jsString))
  Set jsObject = GetObjectProperty(jsObject, "payload")
  lCount = GetProperty(jsObject, "length")
  ReDim aRes(1 To lCount, 1 To 6)

  For Each jsKey In jsObject
    lRow = lRow + 1
    aRes(lRow, 1) = lRow
    aRes(lRow, 2) = GetProperty(jsKey, "displayName")
    aRes(lRow, 3) = GetProperty(jsKey, "purchaseDescription")
    aRes(lRow, 4) = GetProperty(jsKey, "savingsValueStatement")
    aRes(lRow, 5) = GetProperty(jsKey, "displayValue")
    aRes(lRow, 6) = GetProperty(jsKey, "valassisOfferId")
  Next

  Sheet1.Range("A:F").ClearContents
  Sheet1.Range("A1:F1").Resize(lRow).Value = aRes
  MsgBox "Done!"
End Sub
Và cải thiện được tốc độ đáng kể. Không biết còn cách nào tăng tốc thêm được nữa không?
 
Và cải thiện được tốc độ đáng kể. Không biết còn cách nào tăng tốc thêm được nữa không?


Tốc độ thì mình không dám bàn, mình chưa đủ khả năng tối ưu code của anh.
Ở đây em chỉ ngẫu hứng làm chơi 1 cách dùng gọi hàm Jscript 1 lần duy nhất làm hết việc từ A-Z. Cái kết quả mà nó trả về ta chỉ Convert lại thành mảng trong VBA. Cái khó khăn ở đây là khái niệm và cách dùng mảng trong Javascript khác quá xa so với VBA, và đương nhiên không có cách gì chuyển đổi trực tiếp qua lại giữa mảng Javascript và mảng VBA.
Ta sẽ tạo ra 1 hàm trong Jscript

Mã:
objScript.AddCode "function parseData(tex) {" & _
    "var dict = new ActiveXObject('Scripting.Dictionary');" & _
    "var jdata = eval('(' + tex + ')');" & _
    "var payload = jdata.payload;" & _
    "var lcount = payload.length;" & _
    "var indez = 0;" & _
    "for(indez = 0; indez < lcount; indez++){" & _
    "var row = payload[indez];" & _
    "dict.add(indez, " & _
    "{m_displayName: row.displayName, " & _
    "m_purchaseDescription: row.valassisOfferId, " & _
    "m_savingsValueStatement: row.purchaseDescription, " & _
    "m_displayValue: row.displayValue, " & _
    "m_valassisOfferId: row.valassisOfferId" & _
    "});" & _
    "}" & _
    "return dict.items();} "

ta sẽ gọi đến hàm này

Mã:
Public Function parseData(jText As String) As Variant
parseData = objScript.Run("parseData", jText)
End Function

Mã:
Dim jRow As Object, arr
arr = parseData(jsString)
  ReDim ares(1 To UBound(arr) + 1, 1 To 6)
  For lRow = 0 To UBound(arr) Step 1
      Set jRow = arr(lRow)
      ares(lRow + 1, 2) = jRow.m_displayName
      ares(lRow + 1, 3) = jRow.m_purchaseDescription
      ares(lRow + 1, 4) = jRow.m_savingsValueStatement
      ares(lRow + 1, 5) = jRow.m_displayValue
      ares(lRow + 1, 6) = jRow.m_valassisOfferId
  Next

Nhanh chậm em không chắc, chỉ ngẫu hứng làm cho vui thôi.
 
Web KT
Back
Top Bottom