网页批量获取快递单信息：1.有个地方总获取不到？2.运行太慢，请教，万谢！

6xiao

网页批量获取快递单信息：1.有个地方总获取不到？2.运行太慢，请教，万谢！
----------------------------------------------------------------------
1.有个地方总获取不到？
网址：http://222.73.105.202/kjcx/cxend.php?wen=单号
网址举例：http://222.73.105.202/kjcx/cxend.php?wen=1000080690768
问题：此网页excel获取不到的地方——网页顶部点击“查询条码分配”后出来的信息“分配给的分公司或业务员: 山东聊城公司莘县分部(分部)(252400)分配时间2010-07-13 ”我需要的是这个里面的“252400”编号，此项自动放在excel     F列“揽件业务员”。
----------------------------------------------------------------------
2.运行太慢，请高手帮忙优化。万分感谢！
全部代码粘贴如下：

Sub 单号_信息_生成()

' 重量=跟踪记录-重量记录最大值

' 目的地=跟踪记录-“派送公司”下方（到达目的地后才能显示）

' 快捷键: Ctrl+Shift+M

' =======================================================================

' 放在最前，获取Excel当前的属性状态，然后将其关闭，关闭一些Excel功能使代码运行更快
screenUpdateState = Application.ScreenUpdating
statusBarState = Application.DisplayStatusBar
calcState = Application.Calculation
eventsState = Application.EnableEvents
displayPageBreakState = ActiveSheet.DisplayPageBreaks '注:这是工作表级的设置
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False '注:这是工作表级的设置

ActiveWorkbook.Unprotect Password:="123456" '工作薄解密
ActiveSheet.Unprotect Password:="770077" '工作表解密

' =======================================================================

'【网页获取】
    Dim i As Long
    Dim sht As Worksheet
    Dim str As String
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set sht = ActiveSheet
    Sheets.Add Sheets(1)
    With sht
        For i = 4 To .Range("a3003").End(xlUp).Row
            str = "http://222.73.105.202/kjcx/cxend.php?wen=" & .Cells(i, 1)
            Sheets(1).Activate
            With ActiveSheet.QueryTables.Add(Connection:= _
                "URL;" & str, Destination:= _
                Range("A2"))
                .Name = "cxend.php?wen=1000080690768"
                .FieldNames = True
                .RowNumbers = False
                .FillAdjacentFormulas = False
                .PreserveFormatting = True
                .RefreshOnFileOpen = False
                .BackgroundQuery = True
                .RefreshStyle = xlInsertDeleteCells
                .SavePassword = False
                .SaveData = True
                .AdjustColumnWidth = True
                .RefreshPeriod = 0
                .WebSelectionType = xlEntirePage
                .WebFormatting = xlWebFormattingNone
                .WebPreFormattedTextToColumns = True
                .WebConsecutiveDelimitersAsOne = True
                .WebSingleBlockTextImport = False
                .WebDisableDateRecognition = False
                .WebDisableRedirections = False
                .Refresh BackgroundQuery:=False
            End With
'            .Cells(i, "C") = Evaluate("MAX(F:F)")
            .Cells(i, "C") = Evaluate("index(" & Sheets(1).Name & "!F:F,match(,0/" & Sheets(1).Name & "!F1:F100,))")    '第一个非0数字
            .Cells(i, "D") = Evaluate("=INDEX(" & Sheets(1).Name & "!F:F,SMALL(IF(ISNUMBER(" & Sheets(1).Name & "!F1:F100)*(" & Sheets(1).Name & "!F1:F100>0),ROW(1:100)),2))")    '第二个非0数字
            .Cells(i, "E") = Evaluate("=INDEX(A5:A200,MATCH(""派送公司"",A5:A200,)+1)") '目的地
            .Cells(i, "H") = Evaluate("A16") '开始时间
            .Cells(i, "I") = Evaluate("C16") '开始记录
            .Cells(i, "J") = Evaluate("INDEX(A5:A200,MATCH(""派送公司"",A5:A200,)-8)") '最后时间
            .Cells(i, "K") = Evaluate("INDEX(C5:C200,MATCH(""认领详情"",C5:C200,)-2)") '最后记录
            Sheets(1).UsedRange.Clear
        Next
    End With
    Sheets(1).Delete
    sht.Activate
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True

' =======================================================================

'【只保存显示所需】
    Sheets.Add After:=Sheets(Sheets.Count)
    Sheets("Sheet2").Select
    Sheets("Sheet2").Name = "【单号-信息自动生成】"
    ActiveWindow.ScrollWorkbookTabs Position:=xlFirst
    Sheets("单号-信息自动生成").Select
    Cells.Select
    Selection.Copy
    Sheets("【单号-信息自动生成】").Select
    Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False '粘贴整表区格式
    Sheets("单号-信息自动生成").Select
    Range("A4:K3003").Select
    Selection.Copy
    Sheets("【单号-信息自动生成】").Select
    Range("A4").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False '粘贴数据区全部
    Sheets("单号-信息自动生成").Select
    Range("A1:K3").Select
    Selection.Copy
    Sheets("【单号-信息自动生成】").Select
    Range("A1").Select
    ActiveSheet.Paste
    Range("A3:K3").Select
    Selection.AutoFilter '筛选
    Application.DisplayAlerts = False '关闭删除提示
    Worksheets("价格表-业务员").Delete
    Worksheets("宏代码公式备份").Delete
    Worksheets("单号-信息自动生成").Delete
    Application.DisplayAlerts = True '启用删除提示

' =======================================================================

'【另存为“桌面\【单号-信息 2012-12-12】【新生成-请马上改名！！！】.xlsm”】
        ChDir "C:\Documents and Settings\Administrator\桌面"
    ActiveWorkbook.SaveAs Filename:= _
        "C:\Documents and Settings\Administrator\桌面\【单号-信息 2012-12-12】【新生成-请马上改名！！！】.xls", FileFormat:= _
        xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
        , CreateBackup:=False

' =======================================================================

'【放在最后，将Excel恢复到代码运行前的设置】
Application.ScreenUpdating = screenUpdateState
Application.DisplayStatusBar = statusBarState
Application.Calculation = calcState
Application.EnableEvents = eventsState
ActiveSheet.DisplayPageBreaks = displayPageBreaksState '注:这是工作表级的设置
Application.Calculation = xlAutomatic

' =======================================================================

'【分离后三位】
    Range("B4:B3003").Select
    Selection.NumberFormatLocal = "0"" ""0"" ""0" '三个字符间插入空格的格式，使朗读简短
    Range("l4").Select
    ActiveCell.FormulaR1C1 = "=IF(ISERROR(1*RC[-10]),"""",1*RC[-10])" '1.错误值不显示:IF(ISERROR(公式),"""",公式) c2.解决双击单元格才能更改显示格式:1*单元格
    Range("l4").Select
    Selection.AutoFill Destination:=Range("l4:l3003"), Type:=xlFillDefault
    Range("l4:l3003").Select
    Selection.Copy
    ActiveWindow.ScrollColumn = 1
    Range("B4").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False '粘贴数值
    Columns("L:L").Select
    Selection.Delete Shift:=xlToLeft '删除L列
' =======================================================================

'【调整列宽，冻结窗口，保存】
    Cells.Select
    Selection.Columns.AutoFit '调整列宽
    Rows("4:4").Select
    ActiveWindow.FreezePanes = True '冻结窗口
    ActiveWorkbook.Protect Password:="123456", Structure:=True, Windows:=False '工作薄上密
    ActiveWorkbook.Save '保存

' =======================================================================

'【读单号后三位】
   
' =======================================================================

End Sub


源文件有点大=2.21M，我放在这里 QQ中转站 ，提取码=139a9290，下载地址：
http://mail.qq.com/cgi-bin/ftnEx ... d&code=139a9290
迅雷下载地址：

http://2.dc.ftn.qq.com/ftn_handl ... a1cbbc6ac0083a58e0/【单号-信息·从网页】·模板·极速2003版.rar?k=513339616f7cf3cf5ebf8a711f320b1f52025d035a025c011c515b53001f0d00000014580c030d1d065658580907580755510004391939918f869cdbfc1fe9f5fe9198c58de1f4c8e38098de9896fd9381d698c58599f2e90303095289d4174250413921&fr=00&&txf_fid=fa16393493889b2c57a4b2aa8a435d94ab0cc6bc

文件打开密码=770077，工作表密码=770077，工作簿密码=123456。

[ 本帖最后由 6xiao 于 2011-3-11 08:25 编辑 ]

6xiao

有网友说问题1 要用“web 浏览器” 控件才行，不会弄。

guojianlin1985

有点深度了。学习！

6xiao

多谢捧场！

6xiao

咋没人呢？好急..

6xiao

有人会吗？用web浏览器控件可以实现吗？

KCFONG

see if help you.
But the web site's response is very slow.
It cannot help.

120HYH

学习高手的。

xmyjk

取不到的地方可以参考一下思路去做
返回的数值是UNICODE的，要去转码。

1. Option Explicit
   
2. Sub chaxun()
   
3. Dim xmlhttp As Object
   
4. 
   
5. Set xmlhttp = CreateObject("Microsoft.XMLHTTP")
   
6. xmlhttp.Open "POST", "http://222.73.105.202/kjcx/ajax.php", False
   
7. xmlhttp.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
   
8. xmlhttp.Send "lb=tmfp&txm=1000080690768"
   
9. Do Until xmlhttp.ReadyState = 4
   
10. DoEvents
    
11. Loop
    
12. 
    
13. If xmlhttp.Status = 200 Then
    
14. Debug.Print xmlhttp.responseText
    
15. 
    
16. Else
    
17.   reportErr (xmlhttp.Status)
    
18. End If
    
19. 
    
20. End Sub
    
21. 
    
22. Sub reportErr(lStatus As Integer)
    
23.         Select Case lStatus
    
24.             Case 400
    
25.                 MsgBox "Bad Request", vbCritical, "连接错误"
    
26.             Case 401
    
27.                 MsgBox "Unauthorized", vbCritical, "连接错误"
    
28.             Case 402
    
29.                 MsgBox "Payment Required", vbCritical, "连接错误"
    
30.             Case 403
    
31.                 MsgBox "Forbidden", vbCritical, "连接错误"
    
32.             Case 404
    
33.                 MsgBox "Not Found", vbCritical, "连接错误"
    
34.             Case 407
    
35.               MsgBox "Proxy Authentication Required", vbCritical, "连接错误"
    
36.             Case 408
    
37.                 MsgBox "Request Timeout", vbCritical, "连接错误"
    
38.             Case 503
    
39.                 MsgBox "Service Unavailable", vbCritical, "连接错误"
    
40.             Case Else
    
41.               MsgBox "Can not reach by other reason", vbCritical, "连接错误"
    
42.         End Select
    
43. End Sub

复制代码

xmyjk

如以上代码返回的是，{"state":"1","wd":"<span class='wltz'>\u5c71\u4e1c\u804a\u57ce\u516c\u53f8(252000)<\/span>\u5206\u914d\u65f6\u95f42010-07-07","fb":"<span class='wltz'>\u5c71\u4e1c\u804a\u57ce\u516c\u53f8\u8398\u53bf\u5206\u90e8(\u5206\u90e8)(252400)<\/span>\u5206\u914d\u65f6\u95f42010-07-13"}

把\u的后面的四位Unicode编码提取出来，用ChrW()函数去转换，就能得到你要的答案。