如何用Excel VBA解析JSON数据（这个对我真的好难！）

zhangjimfu · 发表于 2015-9-6 14:15

本帖最后由 zhangjimfu 于 2015-9-6 14:16 编辑

一、问题描述：

如何把JSON数据转换成EXCEL格式的文档，便于财务人员做统计用，我自已尝试了几种方法，都无功而返，请各位过走路过的大侠们助我一臂之力，万分感谢！
（注：公司现在在用的收银系统没有办法提供统计报表，故不得不从后台导数据自己统计，导出来后发现都是JSON数据，还是不能统计。）
JSON数据格式如下：
{"1":{"id":1,"pid":"3600","cid":"1376","name":"\u8702\u871c\u67da\u5b50\u8336 Honey Citron Tea","price":"30","mprice":"0","ctype":"0","is_discount":"1","second_discount":"1","is_free":0,"cost":"0","num":"1","type":"","practice_id":"6"},"2":{"id":2,"pid":"3536","cid":"1370","name":"\u62ff\u94c1 Caffe Latte","price":"32","mprice":"0","ctype":"0","is_discount":"1","second_discount":"1","is_free":0,"cost":"0","num":"1","type":""}}

附件：

JSON数据.rar (11.25 KB, 下载次数: 212)

二、我尝试的两种解决方法：

方法一，不知道哪里出错，每次都执行不下去。（注：我对正则表达式完全看不懂，我保证我百度看过正则表达式。）
Sub testJson()    '方法一
Dim a, ind
Dim re As Object
Dim mc As Object, mc2 As Object, m As Object
Set re = CreateObject("VBSCRIPT.REGEXP")
json = Sheets("Sheet1").Range("A1").Value

With re
      .Pattern = """pid"":\d+.\d+,""name"":\d+.\d+"
      .Global = True
      Set mc = .Execute(json)
End With

If mc.Count > 0 Then
      ReDim a(0 To mc.Count - 1, 0 To 1)
      'ind = 1
      For ind = 0 To mc.Count - 1
         Set m = mc(ind)
         With re
            .Pattern = "\d+.\d+"
            .Global = True
            Set mc2 = .Execute(m.Value)
            a(ind, 0) = mc2(0)
            a(ind, 1) = mc2(1)
         End With
      Next ind
End If

For ind = 0 To UBound(a, 1)
      Debug.Print a(ind, 0), a(ind, 1)
Next ind

End Sub

=============================================================================================》

方法二，代码能执行下去，但是有两个问题不知道怎么回事：
1.代码MsgBox y.t1.pid，如果改成MsgBox y.1.pid，或MsgBox y.t1.name就会出错，没办法执行；
2.因为JSON数据的长短会根据客人点的饮料多少而变化，通过这个方法怎样才能把所有数据取出来。

Sub bluejson() '方法二
Dim aa, y As Object
Set x = CreateObject("ScriptControl"): x.Language = "JScript"

aa = Sheets("Sheet1").Range("A5").Value
Set y = x.eval("eval(" & aa & ")")
MsgBox y.t1.pid

End Sub

三、数据详见附件（注：如果有其他简单快捷的方法解析JSON数据也请大侠们指教）

LIUZHU · 发表于 2015-9-6 14:32

能不能明确下目标格式是怎样的，希望在附件中体现出来，以方便别人对着这个目标编写代码

onlycxb · 发表于 2015-9-6 14:41

Sub bluejson() '方法二
Dim aa, y As Object
Set x = CreateObject("ScriptControl"): x.Language = "JScript"
aa = Sheets("Sheet1").Range("A5").Value
Set y = x.eval("eval(" & aa & ")")
MsgBox y.t1.pid

End Sub

zhangjimfu · 发表于 2015-9-6 14:49

LIUZHU 发表于 2015-9-6 14:32
能不能明确下目标格式是怎样的，希望在附件中体现出来，以方便别人对着这个目标编写代码

兄弟，多谢提醒，有劳了！下图是我想要的效果：
QQ图片20150906144345.png

zhangjimfu · 发表于 2015-9-6 14:53

onlycxb 发表于 2015-9-6 14:41
Sub bluejson() '方法二
Dim aa, y As Object
Set x = CreateObject("ScriptControl"): x.L ...

兄弟，真正的数据源是A1单元格里面的数据，因为A1单元格数据源没有办法用这个代码所以我把数据源改成了A5单元格的格式。

coby001 · 发表于 2015-9-6 15:00

Sub bluejson() '方法二
Dim aa, y As Object, x As Object
Dim name, id ' 这里重新定义 json 中的 key，避免vba自动改大小写而失败。
Set x = CreateObject("ScriptControl")
x.Language = "JScript"
aa = Sheets("Sheet1").Range("A5").Value
Set y = x.eval("eval(" & aa & ")")
With CallByName(y, "1", VbGet)
Debug.Print .id, .pid, .name
End With
End Sub

onlycxb · 发表于 2015-9-6 15:02

本帖最后由 onlycxb 于 2015-9-6 15:04 编辑

zhangjimfu 发表于 2015-9-6 14:53
兄弟，真正的数据源是A1单元格里面的数据，因为A1单元格数据源没有办法用这个代码所以我把数据源改成了A5 ...

Sub bluejson() '方法二
Dim aa, y As Object
Set x = CreateObject("ScriptControl"): x.Language = "JScript"
aa = Sheets("Sheet1").Range("A1").Value
MsgBox x.eval("var a=" & aa & ";s='';for(x in a){ for(y in a[x]){s+=a[x][y]+'\t';}s+='\r'}")
End Sub

复制代码

crazy0qwer · 发表于 2015-9-6 16:37

zhangjimfu 发表于 2015-9-6 14:53
兄弟，真正的数据源是A1单元格里面的数据，因为A1单元格数据源没有办法用这个代码所以我把数据源改成了A5 ...

方法三：

Option Explicit
Sub Crazy0qwer()
Dim Ar, Br
Dim I As Long, J As Long, X As Long, X1 As Long
Dim N As Long, C As Long, R As Long, L As Long
Dim S As String, S1 As String, SS As String
Dim D As Object
Set D = CreateObject("SCRIPTING.DICTIONARY")
Ar = Sheets("SHEET1").Range("A1:A" & Sheets("SHEET1").[A65536].End(xlUp).Row)
ReDim Br(1 To 1000, 1 To 100)
D("AAA") = 1
For I = 1 To UBound(Ar)
If Ar(I, 1) <> "" Then
L = InStr(Ar(I, 1), """")
R = InStr(L + 1, Ar(I, 1), """")
SS = Mid(Ar(I, 1), L + 1, R - L - 1)
L = 2: C = 1
Do
L = InStr(L + 1, Ar(I, 1), "{")
If L = 0 Then Exit Do
R = InStr(L, Ar(I, 1), "}")
X = L
N = N + 1
Br(N, 1) = SS
Do
X = InStr(X + 1, Ar(I, 1), ":")
If X = 0 Or X > R Then Exit Do
X1 = InStrRev(Ar(I, 1), """", X - 2)
S = Mid(Ar(I, 1), X1 + 1, X - X1 - 2)
If D.EXISTS(S) = False Then D(S) = C + 1: C = C + 1
X1 = InStr(X, Ar(I, 1), ",")
If X1 > R Or X1 = 0 Then X1 = R
S1 = Replace(Mid(Ar(I, 1), X + 1, X1 - X - 1), """", "")
X1 = D(S)
If InStr(S1, "\u") Then
Br(N, X1) = Right(S1, Len(S1) - InStr(S1, " ") + 1)
S1 = Left(S1, InStr(S1, " ") - 1)
S1 = Replace(S1, "\u", "&H")
For J = Len(S1) - 5 To 1 Step -6
Br(N, X1) = ChrW(Mid(S1, J, 6)) & Br(N, X1)
Next
Else
Br(N, X1) = S1
End If
Loop
Loop Until L = 0
End If
Next
C = D.Count
With Sheets("SHEET2")
.Cells.Clear
.[A1].Resize(1, C) = D.KEYS
.[A2].Resize(N, C) = Br
End With
End Sub

复制代码

zhangjimfu · 发表于 2015-9-6 16:47

crazy0qwer 发表于 2015-9-6 16:37
方法三：

兄弟，我真的有点感动了，你我非亲非故，写这么长的代码一定花了你不少时间和精力，不管能不能解决问题，先感谢了！

zhangjimfu · 发表于 2015-9-6 16:55

onlycxb 发表于 2015-9-6 15:02

大侠，你的代码我测试过了，这就是我想要的，非常感谢！
另外，有两个不情之请：
1、转换过的数据能否像我发的图片一样放到EXCEL工作表里面的每个单元格。
2、能否解释一样代码的原理（因为还有其他的数据，不好总是麻烦大家了）。
x.eval("var a=" & aa & ";s='';for(x in a){ for(y in a[x]){s+=a[x][y]+'\t';}s+='\r'}")

		自动登录	找回密码
密码			免费注册

[求助] 如何用Excel VBA解析JSON数据（这个对我真的好难！）