[已解决]VBA链接网站快递100数据，提取表格显示问题

hyfire2008

刚在网上看到有个网友分享了一个用excelVBA 制作的快递查询工具，但是下载后发现查询的结果跟踪记录显示成了时间，烦请帮忙改正一下，谢谢 Excel查快递.zip (16.77 KB, 下载次数: 8)

2017-10-18 13:50 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

苏子龙

2017-10-18 15:50

1. Sub Main()
   
2.     Dim strText As String, Url As String
   
3.     Dim sType As String, sNum As String, sTypeSelect As String
   
4.     Dim ar(1 To 99, 1 To 2), i As Integer, Mh As Object
   
5.     sTypeSelect = [b2]:    sNum = [b3]
   
6.     If sTypeSelect = "中通" Then
   
7.         sType = "zhongtong"
   
8.     ElseIf sTypeSelect = "申通" Then
   
9.         sType = "shentong"
   
10.     ElseIf sTypeSelect = "圆通" Then
    
11.         sType = "yuantong"
    
12.     ElseIf sTypeSelect = "顺丰" Then
    
13.         sType = "shunfeng"
    
14.     ElseIf sTypeSelect = "EMS" Then
    
15.         sType = "ems"
    
16.     ElseIf sTypeSelect = "全峰快递" Then
    
17.         sType = "quanfengkuaidi"
    
18.     ElseIf sTypeSelect = "天天" Then
    
19.         sType = "tiantian"
    
20.     ElseIf sTypeSelect = "宅急送" Then
    
21.         sType = "zhaijisong"
    
22.     ElseIf sTypeSelect = "安能" Then
    
23.         sType = "anneng"
    
24.     ElseIf sTypeSelect = "德邦" Then
    
25.         sType = "debang"
    
26.     ElseIf sTypeSelect = "速尔" Then
    
27.         sType = "suer"
    
28.     ElseIf sTypeSelect = "韵达" Then
    
29.         sType = "yunda"
    
30.     Else '
    
31.        MsgBox "'该快递公司无法识别:" & sTypeSelect
    
32.         Exit Sub
    
33.     End If
    
34.     Url = " http://www.kuaidi100.com/query?type=" & sType & "&postid=" & sNum
    
35.     With CreateObject("MSXML2.XMLHTTP")
    
36.         .Open "GET", Url, False
    
37.         .Send
    
38.         strText = .responsetext
    
39.     End With
    
40. '    Debug.Print strText
    
41.     With CreateObject("vbscript.regexp")
    
42.         .Global = True
    
43.         .Pattern = "ftime"":""([0-9\- :]+)"",""context"":""(.+?)"",""location"
    
44.         Set Mh = .Execute(strText)
    
45.         If Mh.Count = 0 Then Exit Sub
    
46.         For i = 1 To Mh.Count
    
47.             ar(i, 1) = Mh(i - 1).submatches(0)
    
48.             ar(i, 2) = Mh(i - 1).submatches(1)
    
49.         Next
    
50.     End With
    
51.     With Range("d2:e100")
    
52.         .ClearContents
    
53.         .Value = ar
    
54.     End With
    
55. End Sub

复制代码

重新做了个，参考网址http://club.excelhome.net/thread-1159783-1-1.html

跳转到最佳答案楼层

苏子龙

1. Sub Main()
   
2.     Dim strText As String, Url As String
   
3.     Dim sType As String, sNum As String, sTypeSelect As String
   
4.     Dim ar(1 To 99, 1 To 2), i As Integer, Mh As Object
   
5.     sTypeSelect = [b2]:    sNum = [b3]
   
6.     If sTypeSelect = "中通" Then
   
7.         sType = "zhongtong"
   
8.     ElseIf sTypeSelect = "申通" Then
   
9.         sType = "shentong"
   
10.     ElseIf sTypeSelect = "圆通" Then
    
11.         sType = "yuantong"
    
12.     ElseIf sTypeSelect = "顺丰" Then
    
13.         sType = "shunfeng"
    
14.     ElseIf sTypeSelect = "EMS" Then
    
15.         sType = "ems"
    
16.     ElseIf sTypeSelect = "全峰快递" Then
    
17.         sType = "quanfengkuaidi"
    
18.     ElseIf sTypeSelect = "天天" Then
    
19.         sType = "tiantian"
    
20.     ElseIf sTypeSelect = "宅急送" Then
    
21.         sType = "zhaijisong"
    
22.     ElseIf sTypeSelect = "安能" Then
    
23.         sType = "anneng"
    
24.     ElseIf sTypeSelect = "德邦" Then
    
25.         sType = "debang"
    
26.     ElseIf sTypeSelect = "速尔" Then
    
27.         sType = "suer"
    
28.     ElseIf sTypeSelect = "韵达" Then
    
29.         sType = "yunda"
    
30.     Else '
    
31.        MsgBox "'该快递公司无法识别:" & sTypeSelect
    
32.         Exit Sub
    
33.     End If
    
34.     Url = " http://www.kuaidi100.com/query?type=" & sType & "&postid=" & sNum
    
35.     With CreateObject("MSXML2.XMLHTTP")
    
36.         .Open "GET", Url, False
    
37.         .Send
    
38.         strText = .responsetext
    
39.     End With
    
40. '    Debug.Print strText
    
41.     With CreateObject("vbscript.regexp")
    
42.         .Global = True
    
43.         .Pattern = "ftime"":""([0-9\- :]+)"",""context"":""(.+?)"",""location"
    
44.         Set Mh = .Execute(strText)
    
45.         If Mh.Count = 0 Then Exit Sub
    
46.         For i = 1 To Mh.Count
    
47.             ar(i, 1) = Mh(i - 1).submatches(0)
    
48.             ar(i, 2) = Mh(i - 1).submatches(1)
    
49.         Next
    
50.     End With
    
51.     With Range("d2:e100")
    
52.         .ClearContents
    
53.         .Value = ar
    
54.     End With
    
55. End Sub

复制代码

重新做了个，参考网址http://club.excelhome.net/thread-1159783-1-1.html

苏子龙

加附件

exc姜

学习