蓝天老师帮忙！请问，不显示的网页数据可以提取码

html2013

bailanhong 发表于 2013-4-16 08:36
一直在等！！

很简单的事情，加个循环就可以了：

Private Sub CommandButton1_Click()    'nature_museum查询
    On Error Resume Next
    With CreateObject("internetexplorer.application")
        .Visible = False
        .Navigate "http://www.nature-museum.net/Spdb/spsearch.aspx"
        While .ReadyState <> 4 Or .busy
            DoEvents
        Wend
        For p = 1 To Range("a65536").End(xlUp).Row
            n = Range("b65536").End(xlUp).Row
            .document.getElementById("txtSearchName").Value = Cells(p, 1)
            .document.getElementById("QueryCmd").Click
            Set r = .document.getElementById("QueryResult").All.tags("table")
            t1 = Timer
            ss = ""
            Do Until Timer > t1 + 1000
                ss = r(0).Rows(0).Cells(1).innerText
                If ss <> "" Then GoTo 1
                DoEvents
                ss = ""
            Loop
1:
            For i = 0 To r.Length - 1
                Set r1 = r(i).Rows
                temp = Split(r1(0).Cells(1).innerText, vbCrLf)
                Range(Cells(i + 1 + n, 2), Cells(i + 1 + n, 1 + UBound(temp))) = temp
                If Left(Cells(i + 1 + n, "D"), 2) = "别名" Then
                    Range("D" & i + 1 + n).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
                End If
            Next i
            n = Range("b65536").End(xlUp).Row
            Range("B" & n & ":H" & n).Borders(xlEdgeBottom).LineStyle = xlContinuous
            Set r = Nothing
        Next p
        .Quit
    End With
End Sub

html2013

bailanhong 发表于 2013-4-16 18:42
请教！！！！

　　　　附件：

bailanhong

html2013 发表于 2013-4-17 21:34
好像有点问题：比如说查询“黄精”。
所以要修改一下：

高手，您好，加了循环还是只能查询一个是怎么回事呀？

bailanhong

html2013 发表于 2013-4-17 21:34
好像有点问题：比如说查询“黄精”。
所以要修改一下：

高手你好！发现问题了，原因是当查询的A列列表中某一个名称没有的时候，网页弹出对话框“没有找到物种记录”，VBA也就停止了，请问要怎么解决呢？

html2013

                     

1. Sub Test()
   
2.     On Error Resume Next
   
3.     sr = encodeURI("黄精")
   
4.     With CreateObject("microsoft.xmlhttp")
   
5.         .Open "GET", "http://www.nature-museum.net/Ajaxserver/server.ashx?service=spdict&method=querybynameauto&format=json&lname=&aname=" & sr, False
   
6.         .setRequestHeader "x-requested-with", "XMLHttpRequest"
   
7.         .setRequestHeader "Connection", "Keep-Alive"
   
8.         .send
   
9.         str1 = "a=" & .responsetext
   
10.         With CreateObject("MSScriptControl.ScriptControl")
    
11.             .Language = "JScript"
    
12.             .AddCode str1
    
13.             n = .Eval("a.length")
    
14.             For p = 0 To n - 1
    
15.                 Cells(p + 1, 1) = .Eval("a[" & p & "].Name_Zh")
    
16.                 Cells(p + 1, 2) = .Eval("a[" & p & "].Name_Latin")
    
17.                 Cells(p + 1, 3) = .Eval("a[" & p & "].SAuthor")
    
18.                 Cells(p + 1, 4) = .Eval("a[" & p & "].FamilyGenus.FamilyName_Zh")
    
19.                 Cells(p + 1, 5) = .Eval("a[" & p & "].FamilyGenus.FamilyName_Latin")
    
20.                 Cells(p + 1, 6) = .Eval("a[" & p & "].FamilyGenus.GenusName_Zh")
    
21.                 m = .Eval("a[" & p & "].NormalNamesList.length")
    
22.                 For j = 0 To m - 1
    
23.                     Cells(p + 1, j + 7) = .Eval("a[" & p & "].NormalNamesList[" & j & "].Name")
    
24.                 Next j
    
25.             Next p
    
26.         End With
    
27.     End With
    
28. End Sub
    
29. 
    
30. Function encodeURI(becoded As String) As String    'url编码
    
31.     Set JS = CreateObject("msscriptcontrol.scriptcontrol")
    
32.     JS.Language = "JavaScript"
    
33.     encodeURI = JS.Eval("encodeURIComponent('" & becoded & "');")
    
34. End Function
    

复制代码

bailanhong

html2013 发表于 2013-6-16 12:28

请问如何对A 列批量化？

wwwconsumer

html2013 发表于 2013-6-16 12:28

楼主果然高人，代码可以执行了，但通过网页查询到的黄精有100条，而你的代码运行只能找到10几条，不知问题在那？

html2013

wwwconsumer 发表于 2013-6-17 01:02
楼主果然高人，代码可以执行了，但通过网页查询到的黄精有100条，而你的代码运行只能找到10几条，不知问题 ...

呵呵，你指的是“模糊查询”吧？
看看下面的：

wwwconsumer

果然是高手，模糊查询和精确查询都有，十分方便。

norl_lao

果然是高手，模糊查询和精确查询都有，学习了。