Import chuỗi JSON vào Excel

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



hoặc:




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

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

Code chạy tốt nhưng có 3 vấn đề xuất hiện:
1> Các bạn để ý câu lệnh Set jsData = JSON.data, ngay khi gõ xong thì chắc chắn chữ data sẽ bị biến thành Data (viết HOA ký tự "D"). Ác cái code này có phân biệt HOA thường nên sẽ bị lỗi (dòng thứ 2 trong kết quả trên trình duyệt là data chứ không phải Data). Tôi đang chơi "ăn gian" bằng cách khai báo biến data trên đầu code (mà chẳng để làm gì)
2> Cũng câu lệnh trên Set jsData = JSON.data, ý tôi là muốn lấy dữ liệu từ nhánh data. Trong trường hợp tôi muốn viết code theo cách tổng quát hơn:

Function GetBigAppTech(ByVal JSON As Object, byVal sProperty as String)
....................
End Function

thì cái đối số sProperty trong hàm sẽ được truyền như thế nào cho câu lệnh trên (ở đây tôi muốn truyền sProperty = "data")
3> Tôi có câu lệnh:

 lCount = JSON.total
  ReDim aRes(1 To lCount, 1 To 3)

là vì may mắn chuỗi JSON trả về có đoạn total: 5 nên từ đây tôi biết được dữ liệu có 5 dòng. Đặt trường hợp chuỗi JSON này không có dòng total: 5 như trên thì bằng cách nào tôi biết được phải khai báo chiều thứ nhất cho mảng aRes bao nhiêu là đủ?
--------------------------
Đang tập tành nên còn nhiều thứ chưa biết nên nhận được sự góp ý từ các bạn. Xin cảm ơn
(thật ra trên mạng có cả 1 thư việc viết sẵn để xử lý nhưng dài quá, trong khi tôi muốn tự mình xây dựng lấy ứng dụng)

 

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!

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 http://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%\syswow64\mshta.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.

 

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

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

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

 

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ỉ ?

 

Ủ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 = "http://warehouse.bigapptech.com.vn/api/material/get"
Private Const URL2  As String = "https://syndication.redplum.com/kilgore/StandardSyndicationPartner/offers/?provider=thor&filterByZipCode=77477&filterByLoyaltyProgram=all"
Public Sub Initialize()
  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 http://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%\syswow64\mshta.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

 

Đ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

Đâ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.

 

Đâ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?

 

Á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

ScriptEngine_86.AddCode "function parseDataDynamic(tex,rsStruct) {" & _
"var dict = new ActiveXObject('Scripting.Dictionary');" & _
"var jdata = eval('(' + tex + ')');" & _
"var jStruct = eval('(' + rsStruct + ')');" & _
"var payload = jdata.payload;" & _
"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;" & _
"rowObj[itemStruc.vbname] = row[itemStruc.jname];" & _
"}" & _
"dict.add(indez,rowObj); " & _
"}" & _
"return dict.items();} "

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)

 

Đâ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?

 

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.

 

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ả

 

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

 

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é

 

Ò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 ?

 

Ơ 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

 

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

 

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!

 

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

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

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

 

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.

.

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.

 

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