这个程序还能再快些吗？

mol1981

各位老师好：
问题：
在Sheet1里有11万行数据，是json格式的，

我通过解析的方式，在Sheet2里显示id gt sp glng glat的键值
以下是我的代码
Sub Macro1()
  mTimer = Timer
  Application.ScreenUpdating = False
  With Sheets("Sheet2")
  .Cells.Clear
Dim arr(), i As Long, j As Long, m As Long, R As Long
R = Sheet1.[A1048576].End(xlUp).Row
arr = Sheet1.Range("A1:A" & R).Value
ReDim brr(1 To UBound(arr, 1), 1 To 5)
m = 0
  Set oDom = CreateObject("htmlfile")
  Set owindow = oDom.parentWindow
For i = 1 To UBound(arr)
  strHtml = arr(i, 1)
  owindow.execScript "a=" & strHtml
   m = m + 1
   For j = 1 To 5
     If j = 1 Then
     brr(m, j) = owindow.eval("a.id")
     End If
     If j = 2 Then
     brr(m, j) = owindow.eval("a.gt")
     End If
     If j = 3 Then
     brr(m, j) = owindow.eval("a.sp")
     End If
     If j = 4 Then
     brr(m, j) = owindow.eval("a.glng")
     End If
     If j = 5 Then
     brr(m, j) = owindow.eval("a.glat")
     End If
     
   Next j
Next i
Sheet2.[A1].Resize(UBound(brr, 1), UBound(brr, 2)).Value = brr
Erase arr
Erase brr
  End With
  Application.ScreenUpdating = True
  MsgBox Timer - mTimer
End Sub

经过实际运行发现，整段代码的运行，大概需要20秒左右的时间，这个代码是我改编的别人的代码，不知道是不是可以再快些，还希望各位老师不吝赐教，谢谢
为了试验大量数据的运行效果，我整合了11万条数据，所以文件比较大
下面是附件
test.part1.rar (2 MB, 下载次数: 6)

2020-1-3 14:40 上传

点击文件名下载附件

test.part2.rar (2 MB, 下载次数: 6)

2020-1-3 14:40 上传

点击文件名下载附件

test.part3.rar (366.51 KB, 下载次数: 7)

2020-1-3 14:40 上传

点击文件名下载附件

kevinchengcw

json格式简单规范，用个取巧的方法

1. Sub test()
   
2. Dim Arr, Rule, Tmp, Result, N&, I&, Str$, Dic As Object, mTimer#
   
3. mTimer = Timer
   
4. With Worksheets("sheet1")
   
5.     Arr = .Range("a1:a" & .Cells(.Rows.Count, 1).End(3).Row).Value
   
6. End With
   
7. Rule = Split("id,gt,sp,glng,glat", ",")
   
8. Set Dic = CreateObject("scripting.dictionary")
   
9. For N = LBound(Rule) To UBound(Rule)
   
10.     Dic(Rule(N)) = ""
    
11. Next N
    
12. ReDim Result(LBound(Arr) To UBound(Arr), LBound(Rule) + 1 To UBound(Rule) + 1)
    
13. Tmp = Split(Arr(LBound(Arr), 1), """")
    
14. For I = LBound(Tmp) To UBound(Tmp)
    
15.     If Dic.exists(Tmp(I)) Then
    
16.         If Tmp(I + 1) = ":" Then
    
17.             Dic(Tmp(I)) = I + 2
    
18.         Else
    
19.             Dic(Tmp(I)) = I + 1
    
20.         End If
    
21.     End If
    
22. Next I
    
23. Rule = Dic.items
    
24. For N = LBound(Arr) To UBound(Arr)
    
25.     Tmp = Split(Arr(N, 1), """")
    
26.     For I = LBound(Rule) To UBound(Rule)
    
27.         If Rule(I) <> "" And Rule(I) <= UBound(Tmp) Then
    
28.             Str = Tmp(Rule(I))
    
29.             If Left(Str, 1) = ":" Then Str = Mid(Str, 2, Len(Str) - 2)
    
30.             Result(N, I + 1) = Str
    
31.         End If
    
32.     Next I
    
33. Next N
    
34. With Worksheets("sheet3")
    
35.     .Cells.Clear
    
36.     .[a1].Resize(UBound(Result), UBound(Result, 2)).Value = Result
    
37. End With
    
38. Set Dic = Nothing
    
39. Debug.Print Timer - mTimer
    
40. End Sub

复制代码

我是来讨说法的

这么简单规整的json数据，excel自带的分列或者数组+split最快吧