Import chuỗi JSON vào Excel

5 Responses

1. hands says:

   27/01/2023 at 8:26 am

   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á 😀

   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 ?

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

   Lưu ý cái thứ trả về từ jsonObj 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.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"

   stackoverflow.com/questions/5861536/getting-the-size-of-an-array-in-an-object

   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.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"

   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ì)

   ô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á.

   Chắc phải chơi kiểu khác quá:

   Public Function GetProperty(ByVal jsObject As Object, ByVal PropertyName As String)
     GetProperty = objScript.Run("getProperty", jsObject, PropertyName)
   End Function

   và

   lCount = GetProperty(jsObject, "length")

   Là khỏi sợ vụ ProperCase

   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é.

   Sub test_JSON()
       Dim json As String
       Dim d, i, dong
       With CreateObject("MSXML2.XMLHTTP")
           .Open "GET", "https://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

   Code cuối cùng của tôi:

   Option Explicit
   Public objScript    As Object
   Public objHTTP      As Object
   Private Const URL1  As String = "https://warehouse.bigapptech.com.vn/api/material/get"
   Private Const URL2  As String = "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)

   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

   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).
   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").

   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:

   Dim data, displayName, length
   Public objScript    As Object
   Public objHTTP      As Object
   Private Const URL1  As String = "https://warehouse.bigapptech.com.vn/api/material/get"
   Private Const URL2  As String = "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

   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ơ.

   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:

   Public objScript    As Object
   Public objHTTP      As Object
   Private Const URL1  As String = "https://warehouse.bigapptech.com.vn/api/material/get"
   Private Const URL2  As String = "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?

   Ủ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á 😀

   Theo như bạn nói thì ScriptControl không dùng được trên Office 64. Vậy xin hỏi dùng cách nào để có độ tương thích cao nhất cho mọi phiên bản Office?
   Cảm ơn!

   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

   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

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

   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.
   Mình Copy đoạn code trên mạng giúp cho việc tạo scriptControl trên máy 64 bit thấy có vẻ chạy được, máy 32 bit chưa thử.

   Public ScriptEngine_86 As Object
   '=====================================
   
   Public Sub InitScriptEngine_86()
   Static oWnd As Object
   Dim sProgID As String
   
   If Not ScriptEngine_86 Is Nothing Then Exit Sub
   
   sProgID = "ScriptControl"
   #If Win64 Then
       If oWnd Is Nothing Then
           Set oWnd = CreateWindow()
           oWnd.execScript "Function CreateObjectx86(sProgID): Set CreateObjectx86 = CreateObject(sProgID) End Function", "VBScript"
       End If
   
   If InStr(TypeName(oWnd), "HTMLWindow") > 0 Then
           Set ScriptEngine_86 = oWnd.CreateObjectx86(sProgID)
       End If
   #Else
       Set ScriptEngine_86 = CreateObject(sProgID)
   #End If
   
   End Sub
   
   Private Function CreateWindow()
   
   ' source https://forum.script-coding.com/viewtopic.php?pid=75356#p75356
   Dim sSignature, oShellWnd, oProc
   
   On Error Resume Next
   sSignature = Left(CreateObject("Scriptlet.TypeLib").GUID, 38)
   CreateObject("WScript.Shell").Run "%systemroot%syswow64mshta.exe about:""<head><script>moveTo(-32000,-32000);document.title='x86Host'</script><hta:application showintaskbar=no /><object id='shell' classid='clsid:8856F961-340A-11D0-A96B-00C04FD705A2'><param name=RegisterAsBrowser value=1></object><script>shell.putproperty('" & sSignature & "',document.parentWindow);</script></head>""", 0, False
   Do
       For Each oShellWnd In CreateObject("Shell.Application").Windows
           Set CreateWindow = oShellWnd.GetProperty(sSignature)
           If Err.Number = 0 Then Exit Function
           Err.Clear
       Next
   Loop
   
   End Function

   Như vậy biến ScriptEngine_86 chính là object scriptControl.

   Cảm ơn bạn!
   Đang mò cái "đống" này và vẫn chưa biết cách áp dụng ra sao

   Ủa anh áp dụng cái nào chưa được nhỉ ?

   đoạn code ở bài 20 thì mình không biết cách áp dụng. Còn bài 21 mình sửa code thế này:

   Public objScript    As Object
   Public objHTTP      As Object
   Private Const URL1  As String = "https://warehouse.bigapptech.com.vn/api/material/get"
   Private Const URL2  As String = "syndication.redplum.com/kilgore/StandardSyndicationPartner/offers/?provider=thor&filterByZipCode=77477&filterByLoyaltyProgram=all"
   Public Sub Initialize()
     Static oWnd As Object
     Dim sProgID As String
   
   If Not objScript Is Nothing Then Exit Sub
   
   sProgID = "ScriptControl"
     #If Win64 Then
       If oWnd Is Nothing Then
         Set oWnd = CreateWindow()
         oWnd.execScript "Function CreateObjectx86(sProgID): Set CreateObjectx86 = CreateObject(sProgID) End Function", "VBScript"
       End If
       If InStr(TypeName(oWnd), "HTMLWindow") > 0 Then
         Set objScript = oWnd.CreateObjectx86(sProgID)
       End If
     #Else
       Set objScript = CreateObject(sProgID)
     #End If
     Set objHTTP = CreateObject("MSXML2.XMLHTTP")
   End Sub
   
   Private Function CreateWindow()
   
   ' source https://forum.script-coding.com/viewtopic.php?pid=75356#p75356
     Dim sSignature, oShellWnd, oProc
   
   On Error Resume Next
     sSignature = Left(CreateObject("Scriptlet.TypeLib").GUID, 38)
     CreateObject("WScript.Shell").Run "%systemroot%syswow64mshta.exe about:""<head><script>moveTo(-32000,-32000);document.title='x86Host'</script><hta:application showintaskbar=no /><object id='shell' classid='clsid:8856F961-340A-11D0-A96B-00C04FD705A2'><param name=RegisterAsBrowser value=1></object><script>shell.putproperty('" & sSignature & "',document.parentWindow);</script></head>""", 0, False
     Do
       For Each oShellWnd In CreateObject("Shell.Application").Windows
         Set CreateWindow = oShellWnd.GetProperty(sSignature)
         If Err.Number = 0 Then Exit Function
         Err.Clear
       Next
     Loop
   End Function
   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 TestJSON2Table1a()
     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

   Chay code báo lỗi:

   Đoán là thứ gì đó sai liên quan đến ngôn ngữ VBScript. Mình sửa "VBScript" thành "JScript" vẫn nhận thông báo lỗi y chang
   Hết biết luôn
   2332

   Đây là file em đã sử dụng, anh xem thử có chạy trên máy anh không.
   Về đối tượng MSXML2.XMLHTTP thì em rất ngại sử dụng lại đối tượng cũ, hồi trước em cũng làm cách sử dụng lại MSXML2.XMLHTTP và đã bị lỗi trên nhiều máy mà không hiểu lý do. Bây giờ em tạo mới luôn đối tượng này mỗi lần muốn request cái gì đó, khỏe re.

   Ái chà! thì ra là mình không biết áp dụng
   Tốc độ chỉ chậm lúc đầu, còn những lần sau thì CỰC NHANH bạn à (nhanh nhất so với tất cả code trong topic này)
   Vấn đề của mình bây giờ là:
   – Trong Sub AddFunc các giá trị cần lấy ra đang được cài "chết"
   – Làm sau để những đoạn như m_displayName: row.displayName hay m_purchaseDescription: row.purchaseDescription thì thằng displayName và purchaseDescription được tùy biến bằng cách truyền từ chuỗi bên ngoài vào?

   Đây là câu hỏi khá thú vị, thực sự thì không khó lắm nếu nắm được cách làm việc của Jscript.
   Ta sẽ nói qua 1 chút về Jscript
   Jscript chấp nhận 2 cách gọi đến 1 phần tử của 1 mảng Object

   arr.name

   hoặc

   arr["name"] hoặc arr['name']

   Khi thực hiện lệnh gán giá trị cho 1 phần tử của mảng

   arr['name'] = 'some value';

   Jscript sẽ cập nhật giá trị tại phần tử tên 'name' ngược lại nếu chưa có phần tử nào tên là 'name' thì sẽ thực hiện chèn mới và gắn giá trị , cách làm này khá giống với Dictionary.

   Như vậy để giải quyết bài toán của anh, ta cần truyền vào 1 chuỗi có dạng Object Array để sau đó Jscript sẽ cast sang Object Array thật.
   Object array này có nhiệm vụ định hướng cho kết quả đầu ra (Object Jrow) sẽ gồm những tên (khóa) nào, được lấy giá trị từ JSON key nào.

   jStruct = "[{'vbname':'m_displayName', 'jname':'displayName'}" & _
   ", {'vbname':'m_purchaseDescription', 'jname':'purchaseDescription'}" & _
   ", {'vbname':'m_savingsValueStatement', 'jname':'savingsValueStatement'}" & _
   ", {'vbname':'m_displayValue', 'jname':'displayValue'}" & _
   ", {'vbname':'m_valassisOfferId', 'jname':'valassisOfferId'}" & _
   "]"

   và hàm Jscript

   chỗ màu đỏ chính là lệnh chèn phần tử cho Object Array đầu ra (rowObj và sau này sẽ là Jrow trong sub getTableFromUrl2)
   itemStruc được linh động do ta truyền vào từ VBA

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

   arr = parseDataDynamic(jsonStr, jStruct)

   Code trong file chạy tốt nhưng có vẻ như vẫn chưa được tùy biến lắm. Bởi tôi sửa Sub getTableFromUrl2 thành:

   Public Sub getTableFromUrl1()
     Dim arr, jsonStr As String, rsArr, lRow As Long, jRow As Object, jStruct As String
     InitScriptEngine_86
   
   jsonStr = DownloadJson(URL1)
     jStruct = "[{'vbname':'m_material_id', 'jname':'material_id'}" & _
              ", {'vbname':'m_material_name', 'jname':'material_name'}" & _
              ", {'vbname':'m_material_inventory', 'jname':'material_inventory'}" & _
              "]"
   
   arr = parseDataDynamic(jsonStr, jStruct)
     ReDim rsArr(1 To UBound(arr) + 1, 1 To 4)
     For lRow = 0 To UBound(arr) Step 1
       Set jRow = arr(lRow)
       rsArr(lRow + 1, 1) = lRow + 1
       rsArr(lRow + 1, 2) = jRow.m_material_id
       rsArr(lRow + 1, 3) = jRow.m_material_name
       rsArr(lRow + 1, 4) = jRow.m_material_inventory
     Next
     Sheet1.Range("A:F").ClearContents
     Sheet1.Range("A1:D1").Resize(lRow).Value = rsArr
     MsgBox "Done! "
   End Sub

   thì lỗi ngay lập tức
   tôi đoán phải sửa lại Sub AddFunc thì mới xong! Phải vậy không bạn?

   anh cần chú ý hàm ParsedataDynamic của Jscript có dòng này

   var payload = jdata.payload

   Tức là Object Array ngoài cùng đang gọi tới phần tử có tên là "payload". Url1 không có phần tử này, chỉ có phần tử tên là "data" thôi.
   Cái này cũng có thể tùy biến từ bên ngoài vào bằng cách thêm 1 tham số nữa để jdata gọi tới. Chẳng hạn

   var payload = jdata[dataname]

   biến dataname được truyền từ ngoài VBA vào.
   Các dòng lệnh Jscript anh phải hiểu rõ từng lệnh nha, cái nào không hiểu la lên liền nha.

   Tới đây là mình bó tay rồi đó. Có code mẫu hoặc file mẫu nào phù hợp thì mình tùy biến lại thôi chứ mình chẳng biết gì về JScript cả

   Vâng thôi không sao, vậy cũng là khó cho anh rồi. Có lẽ ta cần thêm thời gian vậy.
   Đây là code Jscript để truyền biến tên phần tử chứa dữ liệu chính của Object array.

   ScriptEngine_86.AddCode "function parseDataDynamic(tex,rsStruct,dataname) {" & _
       "var dict = new ActiveXObject('Scripting.Dictionary');" & _
       "var jdata = eval('(' + tex + ')');" & _
       "var jStruct = eval('(' + rsStruct + ')');" & _
       "var payload = jdata[dataname];" & _
       "var lcount = payload.length;" & _
       "var lStrucLen = jStruct.length;" & _
       "var indez = 0; var i = 0;" & _
       "for(indez = 0; indez < lcount; indez++){" & _
       "var row = payload[indez];" & _
       "var rowObj = {};" & _
       "for(i = 0; i < lStrucLen; i++){" & _
       "var itemStruc = jStruct[i];" & _
       "rowObj[itemStruc.vbname] = row[itemStruc.jname];" & _
       "}" & _
       "dict.add(indez,rowObj); " & _
       "}" & _
       "return dict.items();} "

   ta sẽ gọi vào bằng cách truyền vào 3 tham số

   Public Sub getTableFromUrl1()
   Dim arr, jsonStr As String, rsArr, lRow As Long, jRow As Object, jStruct As String, dataname As String
   InitScriptEngine_86
   
   jsonStr = DownloadJson(URL1)
   jStruct = "[{'vbname':'m_material_id', 'jname':'material_id'}" & _
            ", {'vbname':'m_material_name', 'jname':'material_name'}" & _
            ", {'vbname':'m_material_inventory', 'jname':'material_inventory'}" & _
            "]"
   
   dataname = "data"
   arr = parseDataDynamic(jsonStr, jStruct, dataname)
   ReDim rsArr(1 To UBound(arr) + 1, 1 To 4)
   For lRow = 0 To UBound(arr) Step 1
     Set jRow = arr(lRow)
     rsArr(lRow + 1, 1) = lRow + 1
     rsArr(lRow + 1, 2) = jRow.m_material_id
     rsArr(lRow + 1, 3) = jRow.m_material_name
     rsArr(lRow + 1, 4) = jRow.m_material_inventory
   Next
   Sheet1.Range("A:F").ClearContents
   Sheet1.Range("A1:D1").Resize(lRow).Value = rsArr
   MsgBox "Done! "
   End Sub

   Ngoài ra còn 1 vấn đề nhỏ nữa bên phần máy 64 bit. Đối tượng HtmlWindow không chịu đóng khi đóng file excel. Do vậy ta phải chèn thêm đoạn code Đóng HtmlWindow khi đóng file

   Private Sub Auto_Close()
   If Not oWnd Is Nothing Then
       oWnd.Close
   End If
   End Sub

   Òa…. Tốc độ đỉnh thật!
   Thật ra tôi đã "cày" nát google và cũng đã tìm được module JsonConverter viết sẵn với mức độ tùy biến rất cao. Tuy nhiên tốc độ quá rùa, convert chỉ 23 phần tử mà nó quay miết phát chán luôn. Mai mốt gặp dữ liệu thật vài ngàn dòng thì thôi nghỉ xài luôn quá.
   Với code ví dụ chi tiết của bạn, tôi biết phải làm gì vào file thật của mình rồi. Một lần nữa cảm ơn bạn nhé

   Ơ thế là mấy file này chỉ là "giỡn" thôi hả anh ? !$@!!

   Là thật đấy nhưng dữ liệu trên URL đang ở dạng thử nghiệm thôi. Bởi vậy điều tôi quan tâm là:
   – Code chạy chính xác
   – Có mức độ tùy biến cao
   – Tốc độ nhanh (vì dữ liệu thật phải vài ngàn dòng)
   —————————-
   ah! Mới test lại thì thấy cái Sub getTableFromUrl2 chạy ngon còn Sub getTableFromUrl1 không trả về kết quả nào cả. Không tìm ra được là nguyên nhân gì cả. Nhờ bạn kiểm tra lại giúp mình với

   Em tải file bài trên mấy lần rồi, chạy code getTableFromUrl1 mấy lần rồi vẫn có kết quả như thường. Anh cần xem kỹ Url1 trả về response gì, local và bên ngoài công ty kết quả có thể khác nhau.

   Xin lỗi bạn! Hồi trưa chạy mấy chục lần vẫn không thành công, giờ chạy lại được
   Ổn rồi, cảm ơn bạn!

   Tình cờ mình đọc được rằng Jscript không làm việc trực tiếp với mảng VBA, nhưng có làm việc được với Object tạo bởi Class Module VBA. Khà Khà, thế là mọi rào cản với mảng VBA sẽ bị đập tan bởi cầu nối "nguy hiểm" này.
   Ta sẽ dùng Class Module tạo ra 1 lớp, lớp này cung cấp các Public Sub để Jscript gián tiếp làm việc được với mảng VBA.
   Lưu ý Class này phải được khai báo Public access

   2336

   ta sẽ khai báo 2 phương thức để bên ngoài gọi vào class module

   Public Sub setDimen(r As Long, c As Long)
   ReDim arr(1 To r, 1 To c)
   End Sub
   
   Public Sub setValue(r As Long, c As Long, newval As Variant)
   arr(r, c) = newval
   End Sub

   Đoạn Jscript sẽ trở thành

   ScriptEngine_86.AddCode "function parseData(tex, cls_arr) {" & _
    "var jdata = eval('(' + tex + ')');" & _
    "var colList = eval('(' + cls_arr.colList + ')');" & _
    "var tableData = jdata[cls_arr.dataname];" & _
    "var lcount = tableData.length;" & _
    "var jStruct = {};" & _
    "var colCount = colList.length;" & _
    "cls_arr.setDimen(lcount + 1, colCount);" & _
    "for(var i = 0; i < colCount; i++){" & _
    " jStruct[colList[i]] = i + 1; " & _
    " cls_arr.setValue(1, i + 1, colList[i]); " & _
    "}" & _
    "for(var indez = 0; indez < lcount; indez++){" & _
    "var row = tableData[indez];" & _
    "for(var colname in jStruct){" & _
    "cls_arr.setValue(indez + 2, jStruct[colname], row[colname]);" & _
    "}" & _
    "}" & _
    "return cls_arr; }"

   Như vậy sau khi Run đoạn Jscript thì kết quả trả về chỉ còn cái mảng VBA, khỏi cần Convert thêm gì nữa, cứ thế đưa vào Sheet là xong.

   Public Sub getTableFromUrl2()
   Dim arr, jsonStr As String, cl_ar As cls_array
   
   InitScriptEngine_86
   
   jsonStr = DownloadJson(URL2)
   Set cl_ar = New cls_array
   cl_ar.colList = "['displayName', 'purchaseDescription', 'savingsValueStatement', 'displayValue', 'valassisOfferId']"
   cl_ar.dataname = "payload"
   Set cl_ar = parseData(jsonStr, cl_ar)
   arr = cl_ar.arr
   Sheet1.Range("A:F").ClearContents
   Sheet1.Range("A1").Resize(UBound(arr), UBound(arr, 2)).Value = arr
   MsgBox "Done! "
   End Sub

   Nhưng mình không biết khi Jscript gọi vào hàm trên VBA tốc độ có bảo đảm hay không ? Cần nhờ anh giúp kiểm thử.

   Tốc độ thì gần như tương đương nhưng tôi thích nhất là mức độ tùy biến cao của nó (tôi đã định nói nhưng sợ làm phiền)
   Cảm ơn sự nhiệt tình của bạn! Code này tôi thích nhất

   Reply
2. hands says:

   27/01/2023 at 8:29 am

   Tình cờ mình đọc được rằng Jscript không làm việc trực tiếp với mảng VBA, nhưng có làm việc được với Object tạo bởi Class Module VBA. Khà Khà, thế là mọi rào cản với mảng VBA sẽ bị đập tan bởi cầu nối "nguy hiểm" này.
   Ta sẽ dùng Class Module tạo ra 1 lớp, lớp này cung cấp các Public Sub để Jscript gián tiếp làm việc được với mảng VBA.
   Lưu ý Class này phải được khai báo Public access

   http://www.giaiphapexcel.com/diendan/attachments/pub-png.196955/?hash=28895d1c5a39ebd5f081d3ce24ce8daa

   ta sẽ khai báo 2 phương thức để bên ngoài gọi vào class module

   Public Sub setDimen(r As Long, c As Long)
   ReDim arr(1 To r, 1 To c)
   End Sub
   
   Public Sub setValue(r As Long, c As Long, newval As Variant)
   arr(r, c) = newval
   End Sub

   Đoạn Jscript sẽ trở thành

   ScriptEngine_86.AddCode "function parseData(tex, cls_arr) {" & _
    "var jdata = eval('(' + tex + ')');" & _
    "var colList = eval('(' + cls_arr.colList + ')');" & _
    "var tableData = jdata[cls_arr.dataname];" & _
    "var lcount = tableData.length;" & _
    "var jStruct = {};" & _
    "var colCount = colList.length;" & _
    "cls_arr.setDimen(lcount + 1, colCount);" & _
    "for(var i = 0; i < colCount; i++){" & _
    " jStruct[colList[i]] = i + 1; " & _
    " cls_arr.setValue(1, i + 1, colList[i]); " & _
    "}" & _
    "for(var indez = 0; indez < lcount; indez++){" & _
    "var row = tableData[indez];" & _
    "for(var colname in jStruct){" & _
    "cls_arr.setValue(indez + 2, jStruct[colname], row[colname]);" & _
    "}" & _
    "}" & _
    "return cls_arr; }"

   Như vậy sau khi Run đoạn Jscript thì kết quả trả về chỉ còn cái mảng VBA, khỏi cần Convert thêm gì nữa, cứ thế đưa vào Sheet là xong.

   Public Sub getTableFromUrl2()
   Dim arr, jsonStr As String, cl_ar As cls_array
   
   InitScriptEngine_86
   
   jsonStr = DownloadJson(URL2)
   Set cl_ar = New cls_array
   cl_ar.colList = "['displayName', 'purchaseDescription', 'savingsValueStatement', 'displayValue', 'valassisOfferId']"
   cl_ar.dataname = "payload"
   Set cl_ar = parseData(jsonStr, cl_ar)
   arr = cl_ar.arr
   Sheet1.Range("A:F").ClearContents
   Sheet1.Range("A1").Resize(UBound(arr), UBound(arr, 2)).Value = arr
   MsgBox "Done! "
   End Sub

   Nhưng mình không biết khi Jscript gọi vào hàm trên VBA tốc độ có bảo đảm hay không ? Cần nhờ anh giúp kiểm thử.

   Bài #31 dùng

   var dict = new ActiveXObject('Scripting.Dictionary')

   nên tạo cơ hội để bị tấn công.

   Không dùng cách bài #31 và không dùng Class Module VBA vẫn được. Không truyền jStruct như bài #31 mà chỉ truyền colList như bài này.

   Vâng, mình rất thích được nghe những người tài như anh chỉ dạy. Ước gì em được xem cách làm bài bản sẽ ra sao. Thật sự thì những bài ở trên em nghĩ sao làm vậy thôi chứ không tham khảo gì các tài liệu bài bản hết. Anh giúp em nhá. 😀

   Thứ nhất tôi không phải người tài. Thứ hai là chưa chắc tôi làm bài bản. Nhiều khi tình cờ biết một cái gì đó, chưa hẳn là sẽ chuẩn.
   Nếu nói như bạn thì tôi xấu hổ lắm không dám múa rìu đâu.
   Tranh luận mà cứ dùng những từ ngữ như thế thì ai dám tranh luận? Ai dám cho là mình sẽ làm đúng bài bản, là tài giỏi, khi mà lĩnh vực bao la và mình chỉ nắm được một khía cạnh nhỏ?

   Em không tranh luận với anh, em cảm thấy thích thú khi được học những phương án tối ưu hơn cách của mình,

   Tôi không nói cách của tôi là tối ưu hơn cách của bạn. Tôi viết rất rõ, bạn đừng làm hiểu lầm thế.
   Tôi chỉ nói là có thể làm khác. Tôi không nói là cái cách khác này là hay hơn, tối ưu hơn. Nó chỉ là một cách khác thôi.

   em thực sự muốn biết nếu không dùng Dictionary và Class Module thì ta sẽ dùng cách gì ? Không cần phải bài bản, đơn giản : ngẫu hứng và vui vẻ, vậy thôi.

   Nếu thế thì tôi nêu ý tưởng. Về cách xử lý thì tôi nghĩ có thể cải tiến, tối ưu. Nếu bạn cải tiến và tối ưu thì hay quá.

   Thực ra tôi chỉ muốn biết nhiều cách cho đầu óc mở mang mà thôi. Một cái class nhỏ thì vướng bận gì đâu. Chỉ là muốn học thêm các cách khác mà thôi.

   Ở đây chúng ta biết vấn đề của mình nằm ở đâu, không phải là đi phân tích JSON thành Object, mà là khi có Object JSON rồi làm sao đưa trở lại thành VBA array theo các tiêu chí mà người lập chủ đề này hướng đến:
   +Tốc độ cao
   +Tùy biến cao

   Ta có 2 hướng đi:
   1.Trả về cho VBA 1 Object, Object này chứa cấu trúc mà VBA có thể làm việc được ( không bị làm phiền bởi chức năng tự động viết hoa chữ cái đầu)
   Hướng này VBA nhận Object xong vẫn phải chạy vòng lặp để điền dữ liệu vào mảng.
   Em có biết cách làm của anh, nhưng không đủ kinh nghiệm để biết khi tách chuỗi bởi ký tự "," liệu có an toàn ? nên đã cố tình dùng các thuộc tính vbname an toàn không bị viết hoa, đây gọi là sức nhỏ lựa việc nhỏ.
   2.Trả về cho VBA 1 mảng => Đây gọi là "việc ai nấy làm". Vì người này không muốn đụng đến mã Jscript, chỉ cần trả về cho anh ta cái mảng VBA là vui vẻ cả làng. Thực ra thì anh ta yêu cầu rất đúng, mô hình làm việc nhóm nên như vậy.
   Chỉ có cái em thắc mắc là không thấy anh ta đề cập đến việc sử dụng Class Module tốc độ có cao không ? (cách này thì anh ta chấm 10 điểm tùy biến). Vì hàm trên Class Module không nằm trên Jscript, và khi chạy nó có phải làm công việc Cast dữ liệu giữa 2 ngôn ngữ chăng ? Nếu có ta lại phải tính tới những việc làm sao để số lần cast dữ liệu là nhỏ nhất.
   Nếu có thể mong anh giúp giải đáp những thắc mắc của em.
   Nhưng suy cho cùng, em vẫn chọn cách sau cùng của mình, gọi Jscript và trả về đúng cái mảng VBA, những người làm chung họ sẽ dễ thực hiện các bước công việc sau mà không cần biết bước trước đã làm gì.
   Cảm ơn anh.

   Nếu có thể mong anh giúp giải đáp những thắc mắc của em.

   Về khoản này thì bạn chắc chắn biết hơn tôi nên bạn tự làm nhé

   Nhưng suy cho cùng, em vẫn chọn cách sau cùng của mình, gọi Jscript và trả về đúng cái mảng VBA, những người làm chung họ sẽ dễ thực hiện các bước công việc sau mà không cần biết bước trước đã làm gì.

   Thì tôi nêu một cách mà tôi chưa thấy thôi. Tôi chưa bàn tới chuyện tốt hơn hay tối ưu hơn. Bạn đọc lại bài đầu của tôi thì bạn thấy là tôi không viết thế.

   Lọc kết quả sau khi trả về thì vẫn gần giống bài #31, chỉ có điều, như tôi đã viết, không dùng ActiveXObject('Scripting.Dictionary'). Thế thôi

   Ai muốn parse JSON trong Excel có thể tham khảo thư viện này, không cần xài ScriptControl :

   Attribute VB_Name = "JsonConverter"
   ''
   ' VBA-JSON v2.3.0
   ' (c) Tim Hall - github.com/VBA-tools/VBA-JSON
   '
   ' JSON Converter for VBA
   '
   ' Errors:
   ' 10001 - JSON parse error
   '
   ' @class JsonConverter
   ' @author tim.hall.engr@gmail.com
   ' @license MIT (https://www.opensource.org/licenses/mit-license.php)
   '' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ '
   '
   ' Based originally on vba-json (with extensive changes)
   ' BSD license included below
   '
   ' JSONLib, https://code.google.com/p/vba-json/
   '
   ' Copyright (c) 2013, Ryo Yokoyama
   ' All rights reserved.
   '
   ' Redistribution and use in source and binary forms, with or without
   ' modification, are permitted provided that the following conditions are met:
   '     * Redistributions of source code must retain the above copyright
   '       notice, this list of conditions and the following disclaimer.
   '     * Redistributions in binary form must reproduce the above copyright
   '       notice, this list of conditions and the following disclaimer in the
   '       documentation and/or other materials provided with the distribution.
   '     * Neither the name of the <organization> nor the
   '       names of its contributors may be used to endorse or promote products
   '       derived from this software without specific prior written permission.
   '
   ' THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
   ' ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
   ' WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
   ' DISCLAIMED. IN NO EVENT SHALL <COPYRIGHT HOLDER> BE LIABLE FOR ANY
   ' DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
   ' (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
   ' LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
   ' ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
   ' (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
   ' SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
   ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ '
   Option Explicit
   
   ' === VBA-UTC Headers
   #If Mac Then
   
   #If VBA7 Then
   
   ' 64-bit Mac (2016)
   Private Declare PtrSafe Function utc_popen Lib "libc.dylib" Alias "popen" _
       (ByVal utc_Command As String, ByVal utc_Mode As String) As LongPtr
   Private Declare PtrSafe Function utc_pclose Lib "libc.dylib" Alias "pclose" _
       (ByVal utc_File As LongPtr) As LongPtr
   Private Declare PtrSafe Function utc_fread Lib "libc.dylib" Alias "fread" _
       (ByVal utc_Buffer As String, ByVal utc_Size As LongPtr, ByVal utc_Number As LongPtr, ByVal utc_File As LongPtr) As LongPtr
   Private Declare PtrSafe Function utc_feof Lib "libc.dylib" Alias "feof" _
       (ByVal utc_File As LongPtr) As LongPtr
   
   #Else
   
   ' 32-bit Mac
   Private Declare Function utc_popen Lib "libc.dylib" Alias "popen" _
       (ByVal utc_Command As String, ByVal utc_Mode As String) As Long
   Private Declare Function utc_pclose Lib "libc.dylib" Alias "pclose" _
       (ByVal utc_File As Long) As Long
   Private Declare Function utc_fread Lib "libc.dylib" Alias "fread" _
       (ByVal utc_Buffer As String, ByVal utc_Size As Long, ByVal utc_Number As Long, ByVal utc_File As Long) As Long
   Private Declare Function utc_feof Lib "libc.dylib" Alias "feof" _
       (ByVal utc_File As Long) As Long
   
   #End If
   
   #ElseIf VBA7 Then
   
   ' https://msdn.microsoft.com/en-us/library/windows/desktop/ms724421.aspx
   ' https://msdn.microsoft.com/en-us/library/windows/desktop/ms724949.aspx
   ' https://msdn.microsoft.com/en-us/library/windows/desktop/ms725485.aspx
   Private Declare PtrSafe Function utc_GetTimeZoneInformation Lib "kernel32" Alias "GetTimeZoneInformation" _
       (utc_lpTimeZoneInformation As utc_TIME_ZONE_INFORMATION) As Long
   Private Declare PtrSafe Function utc_SystemTimeToTzSpecificLocalTime Lib "kernel32" Alias "SystemTimeToTzSpecificLocalTime" _
       (utc_lpTimeZoneInformation As utc_TIME_ZONE_INFORMATION, utc_lpUniversalTime As utc_SYSTEMTIME, utc_lpLocalTime As utc_SYSTEMTIME) As Long
   Private Declare PtrSafe Function utc_TzSpecificLocalTimeToSystemTime Lib "kernel32" Alias "TzSpecificLocalTimeToSystemTime" _
       (utc_lpTimeZoneInformation As utc_TIME_ZONE_INFORMATION, utc_lpLocalTime As utc_SYSTEMTIME, utc_lpUniversalTime As utc_SYSTEMTIME) As Long
   
   #Else
   
   Private Declare Function utc_GetTimeZoneInformation Lib "kernel32" Alias "GetTimeZoneInformation" _
       (utc_lpTimeZoneInformation As utc_TIME_ZONE_INFORMATION) As Long
   Private Declare Function utc_SystemTimeToTzSpecificLocalTime Lib "kernel32" Alias "SystemTimeToTzSpecificLocalTime" _
       (utc_lpTimeZoneInformation As utc_TIME_ZONE_INFORMATION, utc_lpUniversalTime As utc_SYSTEMTIME, utc_lpLocalTime As utc_SYSTEMTIME) As Long
   Private Declare Function utc_TzSpecificLocalTimeToSystemTime Lib "kernel32" Alias "TzSpecificLocalTimeToSystemTime" _
       (utc_lpTimeZoneInformation As utc_TIME_ZONE_INFORMATION, utc_lpLocalTime As utc_SYSTEMTIME, utc_lpUniversalTime As utc_SYSTEMTIME) As Long
   
   #End If
   
   #If Mac Then
   
   #If VBA7 Then
   Private Type utc_ShellResult
       utc_Output As String
       utc_ExitCode As LongPtr
   End Type
   
   #Else
   
   Private Type utc_ShellResult
       utc_Output As String
       utc_ExitCode As Long
   End Type
   
   #End If
   
   #Else
   
   Private Type utc_SYSTEMTIME
       utc_wYear As Integer
       utc_wMonth As Integer
       utc_wDayOfWeek As Integer
       utc_wDay As Integer
       utc_wHour As Integer
       utc_wMinute As Integer
       utc_wSecond As Integer
       utc_wMilliseconds As Integer
   End Type
   
   Private Type utc_TIME_ZONE_INFORMATION
       utc_Bias As Long
       utc_StandardName(0 To 31) As Integer
       utc_StandardDate As utc_SYSTEMTIME
       utc_StandardBias As Long
       utc_DaylightName(0 To 31) As Integer
       utc_DaylightDate As utc_SYSTEMTIME
       utc_DaylightBias As Long
   End Type
   
   #End If
   ' === End VBA-UTC
   
   Private Type json_Options
       ' VBA only stores 15 significant digits, so any numbers larger than that are truncated
       ' This can lead to issues when BIGINT's are used (e.g. for Ids or Credit Cards), as they will be invalid above 15 digits
       ' See: https://support.microsoft.com/kb/269370
       '
       ' By default, VBA-JSON will use String for numbers longer than 15 characters that contain only digits
       ' to override set `JsonConverter.JsonOptions.UseDoubleForLargeNumbers = True`
       UseDoubleForLargeNumbers As Boolean
   
   ' The JSON standard requires object keys to be quoted (" or '), use this option to allow unquoted keys
       AllowUnquotedKeys As Boolean
   
   ' The solidus (/) is not required to be escaped, use this option to escape them as / in ConvertToJson
       EscapeSolidus As Boolean
   End Type
   Public JsonOptions As json_Options
   
   ' ============================================= '
   ' Public Methods
   ' ============================================= '
   
   ''
   ' Convert JSON string to object (Dictionary/Collection)
   '
   ' @method ParseJson
   ' @param {String} json_String
   ' @return {Object} (Dictionary or Collection)
   ' @throws 10001 - JSON parse error
   ''
   Public Function ParseJson(ByVal JsonString As String) As Object
       Dim json_Index As Long
       json_Index = 1
   
   ' Remove vbCr, vbLf, and vbTab from json_String
       JsonString = VBA.Replace(VBA.Replace(VBA.Replace(JsonString, VBA.vbCr, ""), VBA.vbLf, ""), VBA.vbTab, "")
   
   json_SkipSpaces JsonString, json_Index
       Select Case VBA.Mid$(JsonString, json_Index, 1)
       Case "{"
           Set ParseJson = json_ParseObject(JsonString, json_Index)
       Case "["
           Set ParseJson = json_ParseArray(JsonString, json_Index)
       Case Else
           ' Error: Invalid JSON string
           Err.Raise 10001, "JSONConverter", json_ParseErrorMessage(JsonString, json_Index, "Expecting '{' or '['")
       End Select
   End Function
   
   ''
   ' Convert object (Dictionary/Collection/Array) to JSON
   '
   ' @method ConvertToJson
   ' @param {Variant} JsonValue (Dictionary, Collection, or Array)
   ' @param {Integer|String} Whitespace "Pretty" print json with given number of spaces per indentation (Integer) or given string
   ' @return {String}
   ''
   Public Function ConvertToJson(ByVal JsonValue As Variant, Optional ByVal Whitespace As Variant, Optional ByVal json_CurrentIndentation As Long = 0) As String
       Dim json_Buffer As String
       Dim json_BufferPosition As Long
       Dim json_BufferLength As Long
       Dim json_Index As Long
       Dim json_LBound As Long
       Dim json_UBound As Long
       Dim json_IsFirstItem As Boolean
       Dim json_Index2D As Long
       Dim json_LBound2D As Long
       Dim json_UBound2D As Long
       Dim json_IsFirstItem2D As Boolean
       Dim json_Key As Variant
       Dim json_Value As Variant
       Dim json_DateStr As String
       Dim json_Converted As String
       Dim json_SkipItem As Boolean
       Dim json_PrettyPrint As Boolean
       Dim json_Indentation As String
       Dim json_InnerIndentation As String
   
   json_LBound = -1
       json_UBound = -1
       json_IsFirstItem = True
       json_LBound2D = -1
       json_UBound2D = -1
       json_IsFirstItem2D = True
       json_PrettyPrint = Not IsMissing(Whitespace)
   
   Select Case VBA.VarType(JsonValue)
       Case VBA.vbNull
           ConvertToJson = "null"
       Case VBA.vbDate
           ' Date
           json_DateStr = ConvertToIso(VBA.CDate(JsonValue))
   
   ConvertToJson = """" & json_DateStr & """"
       Case VBA.vbString
           ' String (or large number encoded as string)
           If Not JsonOptions.UseDoubleForLargeNumbers And json_StringIsLargeNumber(JsonValue) Then
               ConvertToJson = JsonValue
           Else
               ConvertToJson = """" & json_Encode(JsonValue) & """"
           End If
       Case VBA.vbBoolean
           If JsonValue Then
               ConvertToJson = "true"
           Else
               ConvertToJson = "false"
           End If
       Case VBA.vbArray To VBA.vbArray + VBA.vbByte
           If json_PrettyPrint Then
               If VBA.VarType(Whitespace) = VBA.vbString Then
                   json_Indentation = VBA.String$(json_CurrentIndentation + 1, Whitespace)
                   json_InnerIndentation = VBA.String$(json_CurrentIndentation + 2, Whitespace)
               Else
                   json_Indentation = VBA.Space$((json_CurrentIndentation + 1) * Whitespace)
                   json_InnerIndentation = VBA.Space$((json_CurrentIndentation + 2) * Whitespace)
               End If
           End If
   
   ' Array
           json_BufferAppend json_Buffer, "[", json_BufferPosition, json_BufferLength
   
   On Error Resume Next
   
   json_LBound = LBound(JsonValue, 1)
           json_UBound = UBound(JsonValue, 1)
           json_LBound2D = LBound(JsonValue, 2)
           json_UBound2D = UBound(JsonValue, 2)
   
   If json_LBound >= 0 And json_UBound >= 0 Then
               For json_Index = json_LBound To json_UBound
                   If json_IsFirstItem Then
                       json_IsFirstItem = False
                   Else
                       ' Append comma to previous line
                       json_BufferAppend json_Buffer, ",", json_BufferPosition, json_BufferLength
                   End If
   
   If json_LBound2D >= 0 And json_UBound2D >= 0 Then
                       ' 2D Array
                       If json_PrettyPrint Then
                           json_BufferAppend json_Buffer, vbNewLine, json_BufferPosition, json_BufferLength
                       End If
                       json_BufferAppend json_Buffer, json_Indentation & "[", json_BufferPosition, json_BufferLength
   
   For json_Index2D = json_LBound2D To json_UBound2D
                           If json_IsFirstItem2D Then
                               json_IsFirstItem2D = False
                           Else
                               json_BufferAppend json_Buffer, ",", json_BufferPosition, json_BufferLength
                           End If
   
   json_Converted = ConvertToJson(JsonValue(json_Index, json_Index2D), Whitespace, json_CurrentIndentation + 2)
   
   ' For Arrays/Collections, undefined (Empty/Nothing) is treated as null
                           If json_Converted = "" Then
                               ' (nest to only check if converted = "")
                               If json_IsUndefined(JsonValue(json_Index, json_Index2D)) Then
                                   json_Converted = "null"
                               End If
                           End If
   
   If json_PrettyPrint Then
                               json_Converted = vbNewLine & json_InnerIndentation & json_Converted
                           End If
   
   json_BufferAppend json_Buffer, json_Converted, json_BufferPosition, json_BufferLength
                       Next json_Index2D
   
   If json_PrettyPrint Then
                           json_BufferAppend json_Buffer, vbNewLine, json_BufferPosition, json_BufferLength
                       End If
   
   json_BufferAppend json_Buffer, json_Indentation & "]", json_BufferPosition, json_BufferLength
                       json_IsFirstItem2D = True
                   Else
                       ' 1D Array
                       json_Converted = ConvertToJson(JsonValue(json_Index), Whitespace, json_CurrentIndentation + 1)
   
   ' For Arrays/Collections, undefined (Empty/Nothing) is treated as null
                       If json_Converted = "" Then
                           ' (nest to only check if converted = "")
                           If json_IsUndefined(JsonValue(json_Index)) Then
                               json_Converted = "null"
                           End If
                       End If
   
   If json_PrettyPrint Then
                           json_Converted = vbNewLine & json_Indentation & json_Converted
                       End If
   
   json_BufferAppend json_Buffer, json_Converted, json_BufferPosition, json_BufferLength
                   End If
               Next json_Index
           End If
   
   On Error GoTo 0
   
   If json_PrettyPrint Then
               json_BufferAppend json_Buffer, vbNewLine, json_BufferPosition, json_BufferLength
   
   If VBA.VarType(Whitespace) = VBA.vbString Then
                   json_Indentation = VBA.String$(json_CurrentIndentation, Whitespace)
               Else
                   json_Indentation = VBA.Space$(json_CurrentIndentation * Whitespace)
               End If
           End If
   
   json_BufferAppend json_Buffer, json_Indentation & "]", json_BufferPosition, json_BufferLength
   
   ConvertToJson = json_BufferToString(json_Buffer, json_BufferPosition)
   
   ' Dictionary or Collection
       Case VBA.vbObject
           If json_PrettyPrint Then
               If VBA.VarType(Whitespace) = VBA.vbString Then
                   json_Indentation = VBA.String$(json_CurrentIndentation + 1, Whitespace)
               Else
                   json_Indentation = VBA.Space$((json_CurrentIndentation + 1) * Whitespace)
               End If
           End If
   
   ' Dictionary
           If VBA.TypeName(JsonValue) = "Dictionary" Then
               json_BufferAppend json_Buffer, "{", json_BufferPosition, json_BufferLength
               For Each json_Key In JsonValue.Keys
                   ' For Objects, undefined (Empty/Nothing) is not added to object
                   json_Converted = ConvertToJson(JsonValue(json_Key), Whitespace, json_CurrentIndentation + 1)
                   If json_Converted = "" Then
                       json_SkipItem = json_IsUndefined(JsonValue(json_Key))
                   Else
                       json_SkipItem = False
                   End If
   
   If Not json_SkipItem Then
                       If json_IsFirstItem Then
                           json_IsFirstItem = False
                       Else
                           json_BufferAppend json_Buffer, ",", json_BufferPosition, json_BufferLength
                       End If
   
   If json_PrettyPrint Then
                           json_Converted = vbNewLine & json_Indentation & """" & json_Key & """: " & json_Converted
                       Else
                           json_Converted = """" & json_Key & """:" & json_Converted
                       End If
   
   json_BufferAppend json_Buffer, json_Converted, json_BufferPosition, json_BufferLength
                   End If
               Next json_Key
   
   If json_PrettyPrint Then
                   json_BufferAppend json_Buffer, vbNewLine, json_BufferPosition, json_BufferLength
   
   If VBA.VarType(Whitespace) = VBA.vbString Then
                       json_Indentation = VBA.String$(json_CurrentIndentation, Whitespace)
                   Else
                       json_Indentation = VBA.Space$(json_CurrentIndentation * Whitespace)
                   End If
               End If
   
   json_BufferAppend json_Buffer, json_Indentation & "}", json_BufferPosition, json_BufferLength
   
   ' Collection
           ElseIf VBA.TypeName(JsonValue) = "Collection" Then
               json_BufferAppend json_Buffer, "[", json_BufferPosition, json_BufferLength
               For Each json_Value In JsonValue
                   If json_IsFirstItem Then
                       json_IsFirstItem = False
                   Else
                       json_BufferAppend json_Buffer, ",", json_BufferPosition, json_BufferLength
                   End If
   
   json_Converted = ConvertToJson(json_Value, Whitespace, json_CurrentIndentation + 1)
   
   ' For Arrays/Collections, undefined (Empty/Nothing) is treated as null
                   If json_Converted = "" Then
                       ' (nest to only check if converted = "")
                       If json_IsUndefined(json_Value) Then
                           json_Converted = "null"
                       End If
                   End If
   
   If json_PrettyPrint Then
                       json_Converted = vbNewLine & json_Indentation & json_Converted
                   End If
   
   json_BufferAppend json_Buffer, json_Converted, json_BufferPosition, json_BufferLength
               Next json_Value
   
   If json_PrettyPrint Then
                   json_BufferAppend json_Buffer, vbNewLine, json_BufferPosition, json_BufferLength
   
   If VBA.VarType(Whitespace) = VBA.vbString Then
                       json_Indentation = VBA.String$(json_CurrentIndentation, Whitespace)
                   Else
                       json_Indentation = VBA.Space$(json_CurrentIndentation * Whitespace)
                   End If
               End If
   
   json_BufferAppend json_Buffer, json_Indentation & "]", json_BufferPosition, json_BufferLength
           End If
   
   ConvertToJson = json_BufferToString(json_Buffer, json_BufferPosition)
       Case VBA.vbInteger, VBA.vbLong, VBA.vbSingle, VBA.vbDouble, VBA.vbCurrency, VBA.vbDecimal
           ' Number (use decimals for numbers)
           ConvertToJson = VBA.Replace(JsonValue, ",", ".")
       Case Else
           ' vbEmpty, vbError, vbDataObject, vbByte, vbUserDefinedType
           ' Use VBA's built-in to-string
           On Error Resume Next
           ConvertToJson = JsonValue
           On Error GoTo 0
       End Select
   End Function
   
   ' ============================================= '
   ' Private Functions
   ' ============================================= '
   
   Private Function json_ParseObject(json_String As String, ByRef json_Index As Long) As Dictionary
       Dim json_Key As String
       Dim json_NextChar As String
   
   Set json_ParseObject = New Dictionary
       json_SkipSpaces json_String, json_Index
       If VBA.Mid$(json_String, json_Index, 1) <> "{" Then
           Err.Raise 10001, "JSONConverter", json_ParseErrorMessage(json_String, json_Index, "Expecting '{'")
       Else
           json_Index = json_Index + 1
   
   Do
               json_SkipSpaces json_String, json_Index
               If VBA.Mid$(json_String, json_Index, 1) = "}" Then
                   json_Index = json_Index + 1
                   Exit Function
               ElseIf VBA.Mid$(json_String, json_Index, 1) = "," Then
                   json_Index = json_Index + 1
                   json_SkipSpaces json_String, json_Index
               End If
   
   json_Key = json_ParseKey(json_String, json_Index)
               json_NextChar = json_Peek(json_String, json_Index)
               If json_NextChar = "[" Or json_NextChar = "{" Then
                   Set json_ParseObject.Item(json_Key) = json_ParseValue(json_String, json_Index)
               Else
                   json_ParseObject.Item(json_Key) = json_ParseValue(json_String, json_Index)
               End If
           Loop
       End If
   End Function
   
   Private Function json_ParseArray(json_String As String, ByRef json_Index As Long) As Collection
       Set json_ParseArray = New Collection
   
   json_SkipSpaces json_String, json_Index
       If VBA.Mid$(json_String, json_Index, 1) <> "[" Then
           Err.Raise 10001, "JSONConverter", json_ParseErrorMessage(json_String, json_Index, "Expecting '['")
       Else
           json_Index = json_Index + 1
   
   Do
               json_SkipSpaces json_String, json_Index
               If VBA.Mid$(json_String, json_Index, 1) = "]" Then
                   json_Index = json_Index + 1
                   Exit Function
               ElseIf VBA.Mid$(json_String, json_Index, 1) = "," Then
                   json_Index = json_Index + 1
                   json_SkipSpaces json_String, json_Index
               End If
   
   json_ParseArray.Add json_ParseValue(json_String, json_Index)
           Loop
       End If
   End Function
   
   Private Function json_ParseValue(json_String As String, ByRef json_Index As Long) As Variant
       json_SkipSpaces json_String, json_Index
       Select Case VBA.Mid$(json_String, json_Index, 1)
       Case "{"
           Set json_ParseValue = json_ParseObject(json_String, json_Index)
       Case "["
           Set json_ParseValue = json_ParseArray(json_String, json_Index)
       Case """", "'"
           json_ParseValue = json_ParseString(json_String, json_Index)
       Case Else
           If VBA.Mid$(json_String, json_Index, 4) = "true" Then
               json_ParseValue = True
               json_Index = json_Index + 4
           ElseIf VBA.Mid$(json_String, json_Index, 5) = "false" Then
               json_ParseValue = False
               json_Index = json_Index + 5
           ElseIf VBA.Mid$(json_String, json_Index, 4) = "null" Then
               json_ParseValue = Null
               json_Index = json_Index + 4
           ElseIf VBA.InStr("+-0123456789", VBA.Mid$(json_String, json_Index, 1)) Then
               json_ParseValue = json_ParseNumber(json_String, json_Index)
           Else
               Err.Raise 10001, "JSONConverter", json_ParseErrorMessage(json_String, json_Index, "Expecting 'STRING', 'NUMBER', null, true, false, '{', or '['")
           End If
       End Select
   End Function
   
   Private Function json_ParseString(json_String As String, ByRef json_Index As Long) As String
       Dim json_Quote As String
       Dim json_Char As String
       Dim json_Code As String
       Dim json_Buffer As String
       Dim json_BufferPosition As Long
       Dim json_BufferLength As Long
   
   json_SkipSpaces json_String, json_Index
   
   ' Store opening quote to look for matching closing quote
       json_Quote = VBA.Mid$(json_String, json_Index, 1)
       json_Index = json_Index + 1
   
   Do While json_Index > 0 And json_Index <= Len(json_String)
           json_Char = VBA.Mid$(json_String, json_Index, 1)
   
   Select Case json_Char
           Case ""
               ' Escaped string, \, or /
               json_Index = json_Index + 1
               json_Char = VBA.Mid$(json_String, json_Index, 1)
   
   Select Case json_Char
               Case """", "", "/", "'"
                   json_BufferAppend json_Buffer, json_Char, json_BufferPosition, json_BufferLength
                   json_Index = json_Index + 1
               Case "b"
                   json_BufferAppend json_Buffer, vbBack, json_BufferPosition, json_BufferLength
                   json_Index = json_Index + 1
               Case "f"
                   json_BufferAppend json_Buffer, vbFormFeed, json_BufferPosition, json_BufferLength
                   json_Index = json_Index + 1
               Case "n"
                   json_BufferAppend json_Buffer, vbCrLf, json_BufferPosition, json_BufferLength
                   json_Index = json_Index + 1
               Case "r"
                   json_BufferAppend json_Buffer, vbCr, json_BufferPosition, json_BufferLength
                   json_Index = json_Index + 1
               Case "t"
                   json_BufferAppend json_Buffer, vbTab, json_BufferPosition, json_BufferLength
                   json_Index = json_Index + 1
               Case "u"
                   ' Unicode character escape (e.g. u00a9 = Copyright)
                   json_Index = json_Index + 1
                   json_Code = VBA.Mid$(json_String, json_Index, 4)
                   json_BufferAppend json_Buffer, VBA.ChrW(VBA.Val("&h" + json_Code)), json_BufferPosition, json_BufferLength
                   json_Index = json_Index + 4
               End Select
           Case json_Quote
               json_ParseString = json_BufferToString(json_Buffer, json_BufferPosition)
               json_Index = json_Index + 1
               Exit Function
           Case Else
               json_BufferAppend json_Buffer, json_Char, json_BufferPosition, json_BufferLength
               json_Index = json_Index + 1
           End Select
       Loop
   End Function
   
   Private Function json_ParseNumber(json_String As String, ByRef json_Index As Long) As Variant
       Dim json_Char As String
       Dim json_Value As String
       Dim json_IsLargeNumber As Boolean
   
   json_SkipSpaces json_String, json_Index
   
   Do While json_Index > 0 And json_Index <= Len(json_String)
           json_Char = VBA.Mid$(json_String, json_Index, 1)
   
   If VBA.InStr("+-0123456789.eE", json_Char) Then
               ' Unlikely to have massive number, so use simple append rather than buffer here
               json_Value = json_Value & json_Char
               json_Index = json_Index + 1
           Else
               ' Excel only stores 15 significant digits, so any numbers larger than that are truncated
               ' This can lead to issues when BIGINT's are used (e.g. for Ids or Credit Cards), as they will be invalid above 15 digits
               ' See: https://support.microsoft.com/kb/269370
               '
               ' Fix: Parse -> String, Convert -> String longer than 15/16 characters containing only numbers and decimal points -> Number
               ' (decimal doesn't factor into significant digit count, so if present check for 15 digits + decimal = 16)
               json_IsLargeNumber = IIf(InStr(json_Value, "."), Len(json_Value) >= 17, Len(json_Value) >= 16)
               If Not JsonOptions.UseDoubleForLargeNumbers And json_IsLargeNumber Then
                   json_ParseNumber = json_Value
               Else
                   ' VBA.Val does not use regional settings, so guard for comma is not needed
                   json_ParseNumber = VBA.Val(json_Value)
               End If
               Exit Function
           End If
       Loop
   End Function
   
   Private Function json_ParseKey(json_String As String, ByRef json_Index As Long) As String
       ' Parse key with single or double quotes
       If VBA.Mid$(json_String, json_Index, 1) = """" Or VBA.Mid$(json_String, json_Index, 1) = "'" Then
           json_ParseKey = json_ParseString(json_String, json_Index)
       ElseIf JsonOptions.AllowUnquotedKeys Then
           Dim json_Char As String
           Do While json_Index > 0 And json_Index <= Len(json_String)
               json_Char = VBA.Mid$(json_String, json_Index, 1)
               If (json_Char <> " ") And (json_Char <> ":") Then
                   json_ParseKey = json_ParseKey & json_Char
                   json_Index = json_Index + 1
               Else
                   Exit Do
               End If
           Loop
       Else
           Err.Raise 10001, "JSONConverter", json_ParseErrorMessage(json_String, json_Index, "Expecting '""' or '''")
       End If
   
   ' Check for colon and skip if present or throw if not present
       json_SkipSpaces json_String, json_Index
       If VBA.Mid$(json_String, json_Index, 1) <> ":" Then
           Err.Raise 10001, "JSONConverter", json_ParseErrorMessage(json_String, json_Index, "Expecting ':'")
       Else
           json_Index = json_Index + 1
       End If
   End Function
   
   Private Function json_IsUndefined(ByVal json_Value As Variant) As Boolean
       ' Empty / Nothing -> undefined
       Select Case VBA.VarType(json_Value)
       Case VBA.vbEmpty
           json_IsUndefined = True
       Case VBA.vbObject
           Select Case VBA.TypeName(json_Value)
           Case "Empty", "Nothing"
               json_IsUndefined = True
           End Select
       End Select
   End Function
   
   Private Function json_Encode(ByVal json_Text As Variant) As String
       ' Reference: https://www.ietf.org/rfc/rfc4627.txt
       ' Escape: ", , /, backspace, form feed, line feed, carriage return, tab
       Dim json_Index As Long
       Dim json_Char As String
       Dim json_AscCode As Long
       Dim json_Buffer As String
       Dim json_BufferPosition As Long
       Dim json_BufferLength As Long
   
   For json_Index = 1 To VBA.Len(json_Text)
           json_Char = VBA.Mid$(json_Text, json_Index, 1)
           json_AscCode = VBA.AscW(json_Char)
   
   ' When AscW returns a negative number, it returns the twos complement form of that number.
           ' To convert the twos complement notation into normal binary notation, add 0xFFF to the return result.
           ' support.microsoft.com/en-us/kb/272138
           If json_AscCode < 0 Then
               json_AscCode = json_AscCode + 65536
           End If
   
   ' From spec, ", , and control characters must be escaped (solidus is optional)
   
   Select Case json_AscCode
           Case 34
               ' " -> 34 -> "
               json_Char = """"
           Case 92
               '  -> 92 -> \
               json_Char = "\"
           Case 47
               ' / -> 47 -> / (optional)
               If JsonOptions.EscapeSolidus Then
                   json_Char = "/"
               End If
           Case 8
               ' backspace -> 8 -> b
               json_Char = "b"
           Case 12
               ' form feed -> 12 -> f
               json_Char = "f"
           Case 10
               ' line feed -> 10 -> n
               json_Char = "n"
           Case 13
               ' carriage return -> 13 -> r
               json_Char = "r"
           Case 9
               ' tab -> 9 -> t
               json_Char = "t"
           Case 0 To 31, 127 To 65535
               ' Non-ascii characters -> convert to 4-digit hex
               json_Char = "u" & VBA.Right$("0000" & VBA.Hex$(json_AscCode), 4)
           End Select
   
   json_BufferAppend json_Buffer, json_Char, json_BufferPosition, json_BufferLength
       Next json_Index
   
   json_Encode = json_BufferToString(json_Buffer, json_BufferPosition)
   End Function
   
   Private Function json_Peek(json_String As String, ByVal json_Index As Long, Optional json_NumberOfCharacters As Long = 1) As String
       ' "Peek" at the next number of characters without incrementing json_Index (ByVal instead of ByRef)
       json_SkipSpaces json_String, json_Index
       json_Peek = VBA.Mid$(json_String, json_Index, json_NumberOfCharacters)
   End Function
   
   Private Sub json_SkipSpaces(json_String As String, ByRef json_Index As Long)
       ' Increment index to skip over spaces
       Do While json_Index > 0 And json_Index <= VBA.Len(json_String) And VBA.Mid$(json_String, json_Index, 1) = " "
           json_Index = json_Index + 1
       Loop
   End Sub
   
   Private Function json_StringIsLargeNumber(json_String As Variant) As Boolean
       ' Check if the given string is considered a "large number"
       ' (See json_ParseNumber)
   
   Dim json_Length As Long
       Dim json_CharIndex As Long
       json_Length = VBA.Len(json_String)
   
   ' Length with be at least 16 characters and assume will be less than 100 characters
       If json_Length >= 16 And json_Length <= 100 Then
           Dim json_CharCode As String
   
   json_StringIsLargeNumber = True
   
   For json_CharIndex = 1 To json_Length
               json_CharCode = VBA.Asc(VBA.Mid$(json_String, json_CharIndex, 1))
               Select Case json_CharCode
               ' Look for .|0-9|E|e
               Case 46, 48 To 57, 69, 101
                   ' Continue through characters
               Case Else
                   json_StringIsLargeNumber = False
                   Exit Function
               End Select
           Next json_CharIndex
       End If
   End Function
   
   Private Function json_ParseErrorMessage(json_String As String, ByRef json_Index As Long, ErrorMessage As String)
       ' Provide detailed parse error message, including details of where and what occurred
       '
       ' Example:
       ' Error parsing JSON:
       ' {"abcde":True}
       '          ^
       ' Expecting 'STRING', 'NUMBER', null, true, false, '{', or '['
   
   Dim json_StartIndex As Long
       Dim json_StopIndex As Long
   
   ' Include 10 characters before and after error (if possible)
       json_StartIndex = json_Index - 10
       json_StopIndex = json_Index + 10
       If json_StartIndex <= 0 Then
           json_StartIndex = 1
       End If
       If json_StopIndex > VBA.Len(json_String) Then
           json_StopIndex = VBA.Len(json_String)
       End If
   
   json_ParseErrorMessage = "Error parsing JSON:" & VBA.vbNewLine & _
                                VBA.Mid$(json_String, json_StartIndex, json_StopIndex - json_StartIndex + 1) & VBA.vbNewLine & _
                                VBA.Space$(json_Index - json_StartIndex) & "^" & VBA.vbNewLine & _
                                ErrorMessage
   End Function
   
   Private Sub json_BufferAppend(ByRef json_Buffer As String, _
                                 ByRef json_Append As Variant, _
                                 ByRef json_BufferPosition As Long, _
                                 ByRef json_BufferLength As Long)
       ' VBA can be slow to append strings due to allocating a new string for each append
       ' Instead of using the traditional append, allocate a large empty string and then copy string at append position
       '
       ' Example:
       ' Buffer: "abc  "
       ' Append: "def"
       ' Buffer Position: 3
       ' Buffer Length: 5
       '
       ' Buffer position + Append length > Buffer length -> Append chunk of blank space to buffer
       ' Buffer: "abc       "
       ' Buffer Length: 10
       '
       ' Put "def" into buffer at position 3 (0-based)
       ' Buffer: "abcdef    "
       '
       ' Approach based on cStringBuilder from vbAccelerator
       ' https://www.vbaccelerator.com/home/VB/Code/Techniques/RunTime_Debug_Tracing/VB6_Tracer_Utility_zip_cStringBuilder_cls.asp
       '
       ' and clsStringAppend from Philip Swannell
       ' github.com/VBA-tools/VBA-JSON/pull/82
   
   Dim json_AppendLength As Long
       Dim json_LengthPlusPosition As Long
   
   json_AppendLength = VBA.Len(json_Append)
       json_LengthPlusPosition = json_AppendLength + json_BufferPosition
   
   If json_LengthPlusPosition > json_BufferLength Then
           ' Appending would overflow buffer, add chunk
           ' (double buffer length or append length, whichever is bigger)
           Dim json_AddedLength As Long
           json_AddedLength = IIf(json_AppendLength > json_BufferLength, json_AppendLength, json_BufferLength)
   
   json_Buffer = json_Buffer & VBA.Space$(json_AddedLength)
           json_BufferLength = json_BufferLength + json_AddedLength
       End If
   
   ' Note: Namespacing with VBA.Mid$ doesn't work properly here, throwing compile error:
       ' Function call on left-hand side of assignment must return Variant or Object
       Mid$(json_Buffer, json_BufferPosition + 1, json_AppendLength) = CStr(json_Append)
       json_BufferPosition = json_BufferPosition + json_AppendLength
   End Sub
   
   Private Function json_BufferToString(ByRef json_Buffer As String, ByVal json_BufferPosition As Long) As String
       If json_BufferPosition > 0 Then
           json_BufferToString = VBA.Left$(json_Buffer, json_BufferPosition)
       End If
   End Function
   
   ''
   ' VBA-UTC v1.0.5
   ' (c) Tim Hall - github.com/VBA-tools/VBA-UtcConverter
   '
   ' UTC/ISO 8601 Converter for VBA
   '
   ' Errors:
   ' 10011 - UTC parsing error
   ' 10012 - UTC conversion error
   ' 10013 - ISO 8601 parsing error
   ' 10014 - ISO 8601 conversion error
   '
   ' @module UtcConverter
   ' @author tim.hall.engr@gmail.com
   ' @license MIT (https://www.opensource.org/licenses/mit-license.php)
   '' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ '
   
   ' (Declarations moved to top)
   
   ' ============================================= '
   ' Public Methods
   ' ============================================= '
   
   ''
   ' Parse UTC date to local date
   '
   ' @method ParseUtc
   ' @param {Date} UtcDate
   ' @return {Date} Local date
   ' @throws 10011 - UTC parsing error
   ''
   Public Function ParseUtc(utc_UtcDate As Date) As Date
       On Error GoTo utc_ErrorHandling
   
   #If Mac Then
       ParseUtc = utc_ConvertDate(utc_UtcDate)
   #Else
       Dim utc_TimeZoneInfo As utc_TIME_ZONE_INFORMATION
       Dim utc_LocalDate As utc_SYSTEMTIME
   
   utc_GetTimeZoneInformation utc_TimeZoneInfo
       utc_SystemTimeToTzSpecificLocalTime utc_TimeZoneInfo, utc_DateToSystemTime(utc_UtcDate), utc_LocalDate
   
   ParseUtc = utc_SystemTimeToDate(utc_LocalDate)
   #End If
   
   Exit Function
   
   utc_ErrorHandling:
       Err.Raise 10011, "UtcConverter.ParseUtc", "UTC parsing error: " & Err.Number & " - " & Err.Description
   End Function
   
   ''
   ' Convert local date to UTC date
   '
   ' @method ConvertToUrc
   ' @param {Date} utc_LocalDate
   ' @return {Date} UTC date
   ' @throws 10012 - UTC conversion error
   ''
   Public Function ConvertToUtc(utc_LocalDate As Date) As Date
       On Error GoTo utc_ErrorHandling
   
   #If Mac Then
       ConvertToUtc = utc_ConvertDate(utc_LocalDate, utc_ConvertToUtc:=True)
   #Else
       Dim utc_TimeZoneInfo As utc_TIME_ZONE_INFORMATION
       Dim utc_UtcDate As utc_SYSTEMTIME
   
   utc_GetTimeZoneInformation utc_TimeZoneInfo
       utc_TzSpecificLocalTimeToSystemTime utc_TimeZoneInfo, utc_DateToSystemTime(utc_LocalDate), utc_UtcDate
   
   ConvertToUtc = utc_SystemTimeToDate(utc_UtcDate)
   #End If
   
   Exit Function
   
   utc_ErrorHandling:
       Err.Raise 10012, "UtcConverter.ConvertToUtc", "UTC conversion error: " & Err.Number & " - " & Err.Description
   End Function
   
   ''
   ' Parse ISO 8601 date string to local date
   '
   ' @method ParseIso
   ' @param {Date} utc_IsoString
   ' @return {Date} Local date
   ' @throws 10013 - ISO 8601 parsing error
   ''
   Public Function ParseIso(utc_IsoString As String) As Date
       On Error GoTo utc_ErrorHandling
   
   Dim utc_Parts() As String
       Dim utc_DateParts() As String
       Dim utc_TimeParts() As String
       Dim utc_OffsetIndex As Long
       Dim utc_HasOffset As Boolean
       Dim utc_NegativeOffset As Boolean
       Dim utc_OffsetParts() As String
       Dim utc_Offset As Date
   
   utc_Parts = VBA.Split(utc_IsoString, "T")
       utc_DateParts = VBA.Split(utc_Parts(0), "-")
       ParseIso = VBA.DateSerial(VBA.CInt(utc_DateParts(0)), VBA.CInt(utc_DateParts(1)), VBA.CInt(utc_DateParts(2)))
   
   If UBound(utc_Parts) > 0 Then
           If VBA.InStr(utc_Parts(1), "Z") Then
               utc_TimeParts = VBA.Split(VBA.Replace(utc_Parts(1), "Z", ""), ":")
           Else
               utc_OffsetIndex = VBA.InStr(1, utc_Parts(1), "+")
               If utc_OffsetIndex = 0 Then
                   utc_NegativeOffset = True
                   utc_OffsetIndex = VBA.InStr(1, utc_Parts(1), "-")
               End If
   
   If utc_OffsetIndex > 0 Then
                   utc_HasOffset = True
                   utc_TimeParts = VBA.Split(VBA.Left$(utc_Parts(1), utc_OffsetIndex - 1), ":")
                   utc_OffsetParts = VBA.Split(VBA.Right$(utc_Parts(1), Len(utc_Parts(1)) - utc_OffsetIndex), ":")
   
   Select Case UBound(utc_OffsetParts)
                   Case 0
                       utc_Offset = TimeSerial(VBA.CInt(utc_OffsetParts(0)), 0, 0)
                   Case 1
                       utc_Offset = TimeSerial(VBA.CInt(utc_OffsetParts(0)), VBA.CInt(utc_OffsetParts(1)), 0)
                   Case 2
                       ' VBA.Val does not use regional settings, use for seconds to avoid decimal/comma issues
                       utc_Offset = TimeSerial(VBA.CInt(utc_OffsetParts(0)), VBA.CInt(utc_OffsetParts(1)), Int(VBA.Val(utc_OffsetParts(2))))
                   End Select
   
   If utc_NegativeOffset Then: utc_Offset = -utc_Offset
               Else
                   utc_TimeParts = VBA.Split(utc_Parts(1), ":")
               End If
           End If
   
   Select Case UBound(utc_TimeParts)
           Case 0
               ParseIso = ParseIso + VBA.TimeSerial(VBA.CInt(utc_TimeParts(0)), 0, 0)
           Case 1
               ParseIso = ParseIso + VBA.TimeSerial(VBA.CInt(utc_TimeParts(0)), VBA.CInt(utc_TimeParts(1)), 0)
           Case 2
               ' VBA.Val does not use regional settings, use for seconds to avoid decimal/comma issues
               ParseIso = ParseIso + VBA.TimeSerial(VBA.CInt(utc_TimeParts(0)), VBA.CInt(utc_TimeParts(1)), Int(VBA.Val(utc_TimeParts(2))))
           End Select
   
   ParseIso = ParseUtc(ParseIso)
   
   If utc_HasOffset Then
               ParseIso = ParseIso - utc_Offset
           End If
       End If
   
   Exit Function
   
   utc_ErrorHandling:
       Err.Raise 10013, "UtcConverter.ParseIso", "ISO 8601 parsing error for " & utc_IsoString & ": " & Err.Number & " - " & Err.Description
   End Function
   
   ''
   ' Convert local date to ISO 8601 string
   '
   ' @method ConvertToIso
   ' @param {Date} utc_LocalDate
   ' @return {Date} ISO 8601 string
   ' @throws 10014 - ISO 8601 conversion error
   ''
   Public Function ConvertToIso(utc_LocalDate As Date) As String
       On Error GoTo utc_ErrorHandling
   
   ConvertToIso = VBA.Format$(ConvertToUtc(utc_LocalDate), "yyyy-mm-ddTHH:mm:ss.000Z")
   
   Exit Function
   
   utc_ErrorHandling:
       Err.Raise 10014, "UtcConverter.ConvertToIso", "ISO 8601 conversion error: " & Err.Number & " - " & Err.Description
   End Function
   
   ' ============================================= '
   ' Private Functions
   ' ============================================= '
   
   #If Mac Then
   
   Private Function utc_ConvertDate(utc_Value As Date, Optional utc_ConvertToUtc As Boolean = False) As Date
       Dim utc_ShellCommand As String
       Dim utc_Result As utc_ShellResult
       Dim utc_Parts() As String
       Dim utc_DateParts() As String
       Dim utc_TimeParts() As String
   
   If utc_ConvertToUtc Then
           utc_ShellCommand = "date -ur `date -jf '%Y-%m-%d %H:%M:%S' " & _
               "'" & VBA.Format$(utc_Value, "yyyy-mm-dd HH:mm:ss") & "' " & _
               " +'%s'` +'%Y-%m-%d %H:%M:%S'"
       Else
           utc_ShellCommand = "date -jf '%Y-%m-%d %H:%M:%S %z' " & _
               "'" & VBA.Format$(utc_Value, "yyyy-mm-dd HH:mm:ss") & " +0000' " & _
               "+'%Y-%m-%d %H:%M:%S'"
       End If
   
   utc_Result = utc_ExecuteInShell(utc_ShellCommand)
   
   If utc_Result.utc_Output = "" Then
           Err.Raise 10015, "UtcConverter.utc_ConvertDate", "'date' command failed"
       Else
           utc_Parts = Split(utc_Result.utc_Output, " ")
           utc_DateParts = Split(utc_Parts(0), "-")
           utc_TimeParts = Split(utc_Parts(1), ":")
   
   utc_ConvertDate = DateSerial(utc_DateParts(0), utc_DateParts(1), utc_DateParts(2)) + _
               TimeSerial(utc_TimeParts(0), utc_TimeParts(1), utc_TimeParts(2))
       End If
   End Function
   
   Private Function utc_ExecuteInShell(utc_ShellCommand As String) As utc_ShellResult
   #If VBA7 Then
       Dim utc_File As LongPtr
       Dim utc_Read As LongPtr
   #Else
       Dim utc_File As Long
       Dim utc_Read As Long
   #End If
   
   Dim utc_Chunk As String
   
   On Error GoTo utc_ErrorHandling
       utc_File = utc_popen(utc_ShellCommand, "r")
   
   If utc_File = 0 Then: Exit Function
   
   Do While utc_feof(utc_File) = 0
           utc_Chunk = VBA.Space$(50)
           utc_Read = CLng(utc_fread(utc_Chunk, 1, Len(utc_Chunk) - 1, utc_File))
           If utc_Read > 0 Then
               utc_Chunk = VBA.Left$(utc_Chunk, CLng(utc_Read))
               utc_ExecuteInShell.utc_Output = utc_ExecuteInShell.utc_Output & utc_Chunk
           End If
       Loop
   
   utc_ErrorHandling:
       utc_ExecuteInShell.utc_ExitCode = CLng(utc_pclose(utc_File))
   End Function
   
   #Else
   
   Private Function utc_DateToSystemTime(utc_Value As Date) As utc_SYSTEMTIME
       utc_DateToSystemTime.utc_wYear = VBA.Year(utc_Value)
       utc_DateToSystemTime.utc_wMonth = VBA.Month(utc_Value)
       utc_DateToSystemTime.utc_wDay = VBA.Day(utc_Value)
       utc_DateToSystemTime.utc_wHour = VBA.Hour(utc_Value)
       utc_DateToSystemTime.utc_wMinute = VBA.Minute(utc_Value)
       utc_DateToSystemTime.utc_wSecond = VBA.Second(utc_Value)
       utc_DateToSystemTime.utc_wMilliseconds = 0
   End Function
   
   Private Function utc_SystemTimeToDate(utc_Value As utc_SYSTEMTIME) As Date
       utc_SystemTimeToDate = DateSerial(utc_Value.utc_wYear, utc_Value.utc_wMonth, utc_Value.utc_wDay) + _
           TimeSerial(utc_Value.utc_wHour, utc_Value.utc_wMinute, utc_Value.utc_wSecond)
   End Function
   
   #End If

   Code này tôi có thử qua (bài trươc có đề cập). Ưu điểm là độ tùy biến cao nhưng nhược điểm là tốc độ quá chậm bạn à
   ————————————————————————

   Tôi không nói cách của tôi là tối ưu hơn cách của bạn. Tôi viết rất rõ, bạn đừng làm hiểu lầm thế.
   Tôi chỉ nói là có thể làm khác. Tôi không nói là cái cách khác này là hay hơn, tối ưu hơn. Nó chỉ là một cách khác thôi.
   Nếu thế thì tôi nêu ý tưởng. Về cách xử lý thì tôi nghĩ có thể cải tiến, tối ưu. Nếu bạn cải tiến và tối ưu thì hay quá.
   Thực ra tôi chỉ muốn biết nhiều cách cho đầu óc mở mang mà thôi. Một cái class nhỏ thì vướng bận gì đâu. Chỉ là muốn học thêm các cách khác mà thôi.

   Cách này cũng rất hay anh à. Tốc độ cao nhưng khả năng sẽ bị lỗi chỗ rowcount = ArrObj.Length (chữ length sau khi gõ xong nó tự đổi thành Length). Em sẽ nghiên cứu lại chỗ Length vào chỗ Split(key, ",") xem có trục trặc gì không rồi tính tiếp
   ————————————————————————
   Nhiều giải pháp quá! Mình tha hồ lựa chọn. Hiện tại chỉ đang thử nghiệm với 20 dòng dữ liệu, đợi có dữ liệu thật khoảng vài ngàn dòng mình sẽ test lại lần nữa
   Cảm ơn tất cả mọi người đã trợ giúp

   Reply
3. hands says:

   27/01/2023 at 8:34 am

   Chuyện tốc độ nó chủ quan, tôi không bàn tới.
   Chuyện tuỳ biến thì cả hai đều như nhau. Việc "mô hình làm việc nhóm nên như vậy" không hẳn thiên về hướng 2.
   Nếu tôi là quản lý nhóm thì chính tôi lại chọn hướng 1. Hàm VBA nhận mảng vẫn in hệt. Tôi chỉ bảo nhóm của tôi viết thêm 1 hàm nhận Object và chuyển nó thành mảng, xong gọi hàm kia. Về sau này, vì lý do gì đó, cái Object kia phải thay đổi thì tôi chỉ cần chú ý đến cái hàm nhận.
   (đó là tôi giả sử cái Object kia là "native" đối với cái hàm sử lý ban đầu. Tức là nó dùng một cấu trúc tương đối tiêu chuẩn, có thể parsed được bởi nhiều ngôn ngữ thông dụng – nếu nó là cái Object đặc biệt cho VBA thì quả là thà exclusive handshake protocol ngay từ đầu cho xong)

   Nó không như nhau. Nếu Object trả về thay đổi cái gì đó mà hàm chuyển Object thành mảng VBA không cần viết lại mới tính là như nhau.
   Nhưng thôi tùy cách nghĩ của từng người. Với mình thì không có yêu cầu cao gì cả, làm được việc là được.

   Tôi chỉ nói về cái chỗ "làm việc nhóm". Chứ chuyện cốt kiếc tôi đã không tham dự từ đầu, và chưa hề đọc 1 dòng code nào.
   Theo nguyên tắc LT HĐT thì tôi thảy cái wrapper cho LTV viết lại dễ hơn thảy nguyên cái code sử lý. Bên viết cai J code không cần phải biết nhiều về VBA, và bên viết code sử lý cũng không cần biết J gì đó (JScrip[t hay JavaScript?). Chỉ thằng viết cái nối ở giữa mới cần.

   Anh có thể lên trang này, tự tạo ra 1000 records dữ liệu và lưu dưới dạng JSON để test tốc độ

   http://www.mockaroo.com/

   Nó không như nhau. Nếu Object trả về thay đổi cái gì đó mà hàm chuyển Object thành mảng VBA không cần viết lại mới tính là như nhau.

   Ở bài trước sau khi gọi parseData code vẫn cần tới script, vì thế không thể hủy đối tượng ScriptEngine_86.
   Bây giờ sau khi gọi parseData ta có thể hủy ngay ScriptEngine_86 vì mọi kết quả đã có trong đối tượng mà ta truyền vào khi gọi parseData. Nhưng đối tượng này ta không phải tạo từ một class bắt buộc phải có. Ta tạo đối tượng từ điển và sau khi gọi parseData thì kết quả có trong từ điển.
   Tóm lại là ta không có var dict = new ActiveXObject('Scripting.Dictionary') trong script và cũng không cần thêm class nào cả.

   Gọi là nghĩ nhiều cách cho cái đầu khỏi han gỉ. Máy lâu ngày không chạy thì luôn han gỉ, hỏng hóc. 😀

   Cũng vui đấy. Ở trên có đường dẫn tạo ngẫu nhiên JSON text, hôm nay ta sẽ tạo thử chuỗi JSON trên 10000 "dòng" rồi lưu vào file text, rồi đọc JSON trong file text để kiểm nghiệm xem cách nào sẽ nhanh hơn, mình cũng chưa biết bên nào ngon, hôm nay khi nào rảnh sẽ thử. hi hi –=0–=0

   Nhiều giải pháp quá! Mình tha hồ lựa chọn. Hiện tại chỉ đang thử nghiệm với 20 dòng dữ liệu, đợi có dữ liệu thật khoảng vài ngàn dòng mình sẽ test lại lần nữa
   Cảm ơn tất cả mọi người đã trợ giúp

   Đã kiểm nghiệm 2 hướng code trên đoạn JSON có 15000 "dòng".
   Kết quả:
   Dùng Dictionary chứa chuỗi : 5 giây.
   Dùng Class Module : 11 giây.

   Bên nào ngon hơn đã rõ.
   Đúng như mình lo ngại, việc chạy lệnh VBA bên trong code Jscript đã làm Jscript tốn nhiều năng lượng chuyển đổi dữ liệu giữa 2 ngôn ngữ.
   Vậy thì hướng đi đúng đắn nhất là cứ nạp chuỗi vào Dictionary, rồi dùng VBA xử lý chuỗi theo cách tổng quát nhất có thể.
   Trong file dưới đây mình đã cố gắng lái code anh batman1 theo hướng tổng quát, có lẽ không còn hướng nào tối ưu hơn được.

   Máy tính mình cùi bắp, test 2 code cho kết quả như nhau = 18s
   Vì file làm việc thật không cần refesh, chỉ nhận giá trị mới ngay khi khởi động và làm việc với các giá trị đó trong toàn bộ phiên làm việc đến khi đóng Excel thì thôi. Vậy nên mình sẽ đưa một phần code lên sub AutoOpen để lấy dữ liệu trước, sau đó thì chỉ còn công đoạn xử lý thôi.
   Đã thí nghiệm theo hướng AutoOpen này và kết quả lấy dữ liệu 15000 dòng trong vòng 1s
   Cảm ơn bạn!

   Có thể có sự nhầm lẫn.
   Tôi test trên máy 16 năm tuổi thì kết quả như sau:

   1. Chỉ riêng LoadTextFile ngốn ~50 s ở 2 trường hợp.
   2. Đoạn sau LoadTextFile cho tới trước Sheet1.Range("A1:F30000").ClearContents ngốn ~5 s ở 2 trường hợp.

   Như thế tốc độ có thể coi là như nhau. Trong đó việc lấy dữ liệu và soạn kết quả vào mảng arr chỉ mất 5 s.

   Vậy có lẽ sự khác nhau còn nằm ở hệ điều hành. Em chỉ diễn tả theo những gì mình nghĩ, có thể không chính xác thực tế, nhưng cũng gần như vậy.
   Máy 32 bit Tạo Object ScriptControl trong chính process Excel
   Máy 64 bit tạo ra 1 Process "Html Application Host" nào đó, Process này lại tạo ra Object ScriptControl. Như vậy Object ScriptControl này không nằm trong process Excel. Dẫn đến việc khi chạy các lệnh trong VBA, nó "thấy lạ" và phải mất công chuyển đổi dữ liệu, dẫn đến khác biệt như trên.

   Nói ngoài lề 1 chút. Hàm LoadTextFile là cách ngắn nhất nhưng không nhanh nhất để đọc dữ liệu trong file text đúng không nhỉ ? Nhưng chắc ta không được bàn cái đó ở đây đâu ha. –=0–=0
   Cám ơn anh.

   Cũng cùng chủ đề nhưng là câu hỏi ngược lại: Có cách nào chuyển 1 table thành chuỗi JSON không?
   Đương nhiên, chuyện xử lý text thông thường mình làm được (mình đã làm bằng cách xem cấu trúc JSON rồi bắt chước theo). Vấn đề ở đây là mình muốn biết JavaScript có làm điều ngược lại được không
   Mình đang hy vọng: nếu dùng công cụ chuyên nghiệp thì tốc độ xử lý phải nhanh hơn
   ???

   Chủ đề quá hay ạ,
   Giờ e có 1 cơ sở dữ liệu chuẩn rồi, muốn biến nó thành JSON lên 1 trang web thì phải làm sao anh?
   (Mục đích để cho dữ liệu nó nhẹ đi, ko phải lưu trên file cho nặng nề)

   Đương nhiên được! Nhưng theo tôi được biết thì hành động download hay upload đều phải được sự cho phép của người quản trị mạng, họ sẽ cung cấp cho bạn 1 api giống như đường link trong bài này là của người bạn cung cấp cho. Vậy nếu bạn muốn, bạn hỏi lại bên quản trị trang web xem sao
   Riêng phần biến dữ liệu thành JSON thì đơn giản rồi, chỉ là xử lý chuỗi thôi

   Trước mắt cứ đưa lên trang web tự tạo của máy mình cũng được anh.
   Rồi thì các máy khác trên mạng LAN có thể join vào đấy để lấy.

   Search good đi bạn: [URL='www.google.com.vn/search?ei=yNxjW8LhEMzt9QOfipCgBA&q=Using+VBA+to+upload+json+data&oq=Using+VBA+to+upload+json+data&gs_l=psy-ab.3..33i160k1.15703.22606.0.23177.11.11.0.0.0.0.221.1308.0j7j1.8.0….0…1.1.64.psy-ab..3.4.695…35i39k1j33i22i29i30k1.0.RS1j8MWA5-Y']Using VBA to upload json data

   Chào Thầy @ndu96081631
   Thầy xem thêm tools bên dưới cũng để hổ trợ dữ liệu Json.
   Trên github và được cộng đồng hỗ trợ rất tốt…
   [URL='github.com/VBA-tools/VBA-JSON']Vba JsonConvert

   Reply
4. hands says:

   27/01/2023 at 8:38 am

   Chào Thầy @ndu96081631
   Thầy xem thêm tools bên dưới cũng để hổ trợ dữ liệu Json.
   Trên github và được cộng đồng hỗ trợ rất tốt…
   [URL='github.com/VBA-tools/VBA-JSON']Vba JsonConvert

   em chào bác @HeSanbi

   em cũng đang mò dùng tool vba jsonconvert để lấy data từ link json vào excel nhưng đa bị vướng chỗ vòng lập for each ạ
   mong bác coi sửa lỗi code dùm em với ạ
   bác xem file em đính kèm nhé
   đa tạ bác

   cấu trúc json
   2342

   items nằm trong result cho nên phải trình bày như thế này, vd: objectJson(result)("items")("totalVolume")

   dạ không được bác @nguyendang95 ơi, làm vậy vba vậy báo lỗi, xin giúp đỡ ạ

   Bạn thử dựa vào mẫu code này xem sao nhé:

   Option Explicit
   
   Private Sub ParseJson()
       Const strURL As String = "fwtapi3.fialda.com/api/services/app/StockInfo/GetHistoricalData?symbol=HPG&fromDate=2022-12-25T08:02:51.007&toDate=2023-01-25T08:02:51.008&pageNumber=1&pageSize=25"
       Dim objWinHttp As Object
       Set objWinHttp = CreateObject("WinHttp.WinHttpRequest.5.1")
       With objWinHttp
           .Open "GET", strURL, True
           .SetRequestHeader "Accept", "application/json"
           .Send
           .WaitForResponse
           If .Status = 200 Then
               Dim objJson As Scripting.Dictionary
               Set objJson = JsonConverter.ParseJson(.ResponseText)
               Dim i As Long
               Debug.Print objJson.item("result")("totalCount")
               If objJson.item("result")("items").Count > 0 Then
                   For i = 1 To objJson.item("result")("items").Count
                       Debug.Print objJson.item("result")("items")(i)("totalVolume")
                   Next
               End If
           Else: MsgBox "An error occurred"
           End If
       End With
   End Sub

   code này hoạt động sao vậy bác ?
   em tay ngang nên ko hiểu lắm ạ

   Code trên chỉ có nhiệm vụ đơn giản là truy xuất các giá trị từ JSON trả về của lần gọi API thành công.

   items là một mảng chứa nhiều đối tượng cùng loại, cho nên JsonConverter sẽ chuyển đổi nó thành Collection.

   Reply
5. hands says:

   09/02/2023 at 8:33 am

   nhờ anh chị giúp đỡ ạ,

   em có lấy dữ liệu từ link json về excel nhưng có link bị lỗi font ạ (file đính kèm)
   anh chị biết cách xử lý sao cho hết lỗi font không, chỉ em với ạ
   em có lấy data trong theo link: "[URL='fiin-fundamental.ssi.com.vn/FinancialAnalysis/GetFinancialRatioV2?language=vi&Type=Company&OrganCode=HPG&Timeline=2022_1&Timeline=2022_2&Timeline=2022_3&Timeline=2022_4']fiin-fundamental.ssi.com.vn…meline=2022_2&Timeline=2022_3&Timeline=2022_4"

   nếu lấy theo For each item in objJson thì được rồi ạ
   còn nếu lấy theo vòng lập i thì đang bị lỗi ạ, mong bác xem giúp ạ, em cảm ơn nhiều ạ
   em có lấy data có cấu trúc tương tự nhưng bị lỗi, không lấy được data, mong bác giúp ạ, em xin cảm ơn trước ạ
   link json:

   fiin-fundamental.ssi.com.vn/FinancialAnalysis/GetFinancialRatioV2?language=vi&Type=Company&OrganCode=HPG&Timeline=2022_1&Timeline=2022_2&Timeline=2022_3&Timeline=2022_4
   câu trúc data json:
   3015
   đang bị lỗi:
   3016
   em xin cảm ơn.

   Thử cái này xem sao nhé.

   Option Explicit
   
   Private Sub ParseJson()
       Const strURL As String = "fiin-fundamental.ssi.com.vn/FinancialAnalysis/GetFinancialRatioV2?language=vi&Type=Company&OrganCode=HPG&Timeline=2022_1&Timeline=2022_2&Timeline=2022_3&Timeline=2022_4"
       Dim objWinHttp As Object
       Set objWinHttp = CreateObject("WinHttp.WinHttpRequest.5.1")
       With objWinHttp
           .Open "GET", strURL, True
           .SetRequestHeader "Accept", "application/json"
           .Send
           .WaitForResponse
           If .Status = 200 Then
               Dim objJson As Scripting.Dictionary
               Set objJson = JsonConverter.ParseJson(.ResponseText)
               Dim i As Long
               If objJson.Item("items").Count > 0 Then
                   For i = 1 To objJson.Item("items").Count
                       Debug.Print objJson.Item("items")(i)("key")
                       Debug.Print objJson.Item("items")(i)("value")("organCode")
                   Next
               End If
           Else: MsgBox "An error occurred"
           End If
       End With
   End Sub

   em chào các anh, chị
   trong link json em thấy có link người ta convert ngày tháng sang 1 dãy số

   hình 1: ngày tháng bình thường

   3019

   hình 2: ngày tháng đã được convert trong kết quả của link json trả về

   3018

   ví dụ làm sao mình biết được dãy số 1677171600 là ngày 02/03/2023 anh chị nhỉ ?

   em cám ơn tất cả các anh chị ạ.

   Function UnixTimestampToDate(Timestamp As Double) As Date
       UnixTimestampToDate = DateAdd("s", Timestamp, #1/1/1970#)
   End Function

   Không chắc là can thiệp được ngay khi tách dữ liệu, nên nếu chưa có giải pháp nào thì bạn xem thử, cho function bên trên vào trước kế quả trả về (xem ví dụ bên dưới).

   '
   Sub Test()
       Dim UnixTimestamp As Double
       UnixTimestamp = 1677171600
       Debug.Print UnixTimestampToDate(UnixTimestamp)
   End Sub

   em chào bác @huhumalu

   em kiểm tra thì thấy kết quả ra ngày 23/02/2023 là không đúng ạ.

   ngày đúng là ngày 02/03/2023

   em cám ơn bác

   3020

   Reply