[已解决] 抓取信息，代码不完整，求完善

YUzero2020

这段代码，不能添加一段，检索不到或者错误责跳过继续继续搜索下一个框
Sub GetID()
Dim User_agent, Response_Text, arr, i
arr = Range("a2:b" & Range("a" & Rows.Count).End(xlDown).Row)
User_agent = "Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/87.0.4280.66 Safari/537.36"
With CreateObject("MSXML2.XMLHTTP")
    For i = 1 To UBound(arr)
    If arr(i, 1) Like "*ttp*" Then
        .Open "get", arr(i, 1), False
        .SetRequestHeader "User-Agent", User_agent
        .Send
        arr(i, 2) = Split(Split(.Responsetext, "shangpin|keycount|product|dianpuname1"">")(1), "</a>")(0)
        End If
    Next
End With
Range("a2").Resize(UBound(arr), 2) = arr
End Sub

高个子

1. Sub GetID()
   
2. Dim User_agent, Response_Text, arr, i
   
3. arr = Range("a2:b" & Range("a" & Rows.Count).End(xlDown).Row)
   
4. User_agent = "Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/87.0.4280.66 Safari/537.36"
   
5. With CreateObject("MSXML2.XMLHTTP")
   
6.     On Error Resume Next
   
7.     For i = 1 To UBound(arr)
   
8.     If arr(i, 1) Like "*ttp*" Then
   
9.         .Open "get", arr(i, 1), False
   
10.         .SetRequestHeader "User-Agent", User_agent
    
11.         .Send
    
12.         arr(i, 2) = Split(Split(.Responsetext, "shangpin|keycount|product|dianpuname1"">")(1), "</a>")(0)
    
13.         End If
    
14.     Next
    
15. End With
    
16. Range("a2").Resize(UBound(arr), 2) = arr
    
17. End Sub
    

复制代码

高个子

店铺名称抓取.zip (19.16 KB, 下载次数: 5)

2023-2-14 18:57 上传

点击文件名下载附件