求代码优化

上进的小白

代码的功能就是查快递的发出地和流转现状，群里相关的帖子都看过了，借鉴了非常多，拼凑出了我想要的代码，但是运行一两百个就不行了，希望能优化。

1. Function kkk()
   
2. Dim sHTML As String '查询返回的HTML值
   
3. Dim sRes As String
   
4. Dim iTimeOut As Integer
   
5. Dim iTimeOutMax As Integer
   
6. Dim aFile As Variant
   
7. 
   
8. Dim arrLine As Variant
   
9. Dim sLine As String '每行跟踪记录
   
10. 
    
11. Dim arrText As Variant
    
12. Dim sText As String '在每行跟踪记录中用于分段获取时间和日志
    
13. 
    
14. Dim iCnt As Integer '循环变量
    
15. 
    
16. Dim iRow As Integer '写入行号
    
17. Dim i As Integer
    
18. Dim sTime As String '每条跟踪记录中对应的时间
    
19. Dim sLog As String '每条跟踪记录中对应的日志
    
20. 
    
21. Dim sNum As String
    
22. Dim sTypeSelect As String
    
23. Dim sType As String
    
24. Dim sURL As String
    
25. Dim iTimeCol As Integer
    
26. Dim iLogCol As Integer
    
27. 
    
28. 
    
29. On Error Resume Next
    
30. Range("f2:i1000").ClearContents '先清除旧结果
    
31. i = 2
    
32. Do While Cells(i, 1) <> ""
    
33.     iRow = 2 '从第2行开始写结果
    
34.     iTimeCol = 4  '写时间的列号
    
35.     iLogCol = 5   '写跟踪记录的列号
    
36.     iTimeOutMax = 8000 '查询超时设置
    
37.    
    
38.     sNum = Cells(i, 2).Value '快递单号
    
39.     sTypeSelect = Cells(i, 1).Value '快递公司选择
    
40.     '下面是将快递公司的中文名转换成对应的代码(应该都是汉语全拼)可以加上其它的快递公司
    
41.     If sTypeSelect = "中通" Then
    
42.         sType = "zhongtong"
    
43.     ElseIf sTypeSelect = "申通" Then
    
44.         sType = "shentong"
    
45.     ElseIf sTypeSelect = "圆通" Then
    
46.         sType = "yuantong"
    
47.     ElseIf sTypeSelect = "顺丰" Then
    
48.         sType = "shunfeng"
    
49.     ElseIf sTypeSelect = "EMS" Then
    
50.         sType = "ems"
    
51.     ElseIf sTypeSelect = "百世" Then
    
52.         sType = "huitongkuaidi"
    
53.     ElseIf sTypeSelect = "宅急送" Then
    
54.         sType = "zhaijisong"
    
55.     ElseIf sTypeSelect = "韵达" Then
    
56.         sType = "yunda"
    
57. 
    
58.     Else
    
59.         Cells(i, 4).Value = "'该快递公司无法识别:" & sTypeSelect
    
60.         Exit Function
    
61.     End If
    
62.    
    
63.     '拼接URL地址
    
64.     sURL = "http://www.kuaidi100.com/query?type=" & sType & "&postid=" & sNum  '借用快递100的查询接口
    
65. 
    
66. Dim ET As New InternetExplorer
    
67.     ET.Visible = False '隐藏IE
    
68.     ET.Navigate sURL  '输入网址
    
69.     iTimeOut = 1
    
70.     Do Until ET.ReadyState = 4 Or iTimeOut > iTimeOutMax '等待页面加载完毕
    
71.       iTimeOut = iTimeOut + 1
    
72.     Loop
    
73.     sHTML = ET.Document.body.innerHTML
    
74. Set ET = Nothing
    
75. 
    
76.     '以下开始解析返回的查询结果
    
77.     If iTimeOut >= iTimeOutMax Then
    
78.       Cells(iRow, iLogCol).Value = "查询超时"
    
79.     ElseIf sHTML = "" Then
    
80.       Cells(iRow, iLogCol).Value = "查询失败！"
    
81.     Else
    
82.         aFile = Split(sHTML, """data"":[{")
    
83.         If UBound(aFile) >= 1 Then
    
84.             sLine = aFile(1)
    
85.             arrLine = Split(sLine, "},{")
    
86.             For iCnt = 0 To UBound(arrLine)
    
87.                 sText = arrLine(iCnt)
    
88.                 arrText = Split(sText, """:""")
    
89.                 If UBound(arrText) >= 2 Then
    
90.                     sTime = arrText(1)
    
91.                     sLog = arrText(3)
    
92.                     sTime = Rep(sTime)
    
93.                     sLog = Rep(sLog)
    
94.                     Cells(iRow, iTimeCol).Value = "'" & sTime
    
95.                     Cells(iRow, iLogCol).Value = "'" & sLog
    
96.                     iRow = iRow + 1
    
97.                 End If
    
98.             Next
    
99.             sRes = aFile(0)
    
100.         Else
     
101.             aFile = Split(sHTML, ":")
     
102.             sRes = aFile(2)
     
103.             Cells(iRow, iLogCol).Value = Rep(sRes)
     
104.         End If
     
105.         Cells(i, 6) = Cells(iRow - 1, iTimeCol)
     
106.         Cells(i, 7) = Cells(iRow - 1, iLogCol)
     
107.         Cells(i, 8) = Cells(2, iTimeCol)
     
108.         Cells(i, 9) = Cells(2, iLogCol)
     
109.     End If
     
110. 
     
111. i = i + 1
     
112. Loop
     
113. End Function
     
114. 
     
115. '替换掉无用的字符串
     
116. Function Rep(str As String) As String
     
117. Dim sRes As String
     
118.     sRes = Replace(str, """", "")
     
119.     sRes = Replace(sRes, "{", "")
     
120.     sRes = Replace(sRes, "}", "")
     
121.     sRes = Replace(sRes, ",context", "")
     
122.     sRes = Replace(sRes, ",ftime", "")
     
123.     sRes = Replace(sRes, ",location", "")
     
124.     Rep = sRes
     
125. End Function

复制代码

上进的小白

就这么沉了吗？有人能帮忙解决下吗？