网抓求助大神帮忙

wu282815876

想要收集这个网站里这些工程的名字，粘贴到excel 点名字能直接打开网页的那种

wbperfect

1. Sub text()
   
2.     Dim str$, html, url$, r%, arr, i%, p%, j%
   
3.     Dim db, dr
   
4.    
   
5.     Application.ScreenUpdating = Fals
   
6.    
   
7.     Set html = CreateObject("htmlfile")
   
8.     k = 1
   
9.     For j = 1 To 1
   
10.         url = "http://ggzy.hefei.gov.cn/jyxx/002001/002001001/moreinfo_jyxxgg2.html"
    
11.         With CreateObject("WinHttp.WinHttpRequest.5.1")
    
12.             .Open "GET", url, False
    
13.             .setRequestHeader "cookie", "fontZoomState=0"
    
14.             .setRequestHeader "Referer", "http://ggzy.hefei.gov.cn/jyxx/002001/002001001/" & j & ".html"
    
15.             .send
    
16.             str = .responseText
    
17.           End With
    
18.           Debug.Print str
    
19.         For r = 0 To 19
    
20.         k = k + 1
    
21.       
    
22.         arr = Split(str, "</li>")(r)
    
23.         Cells(k, 1) = Split(Split(Split(arr, "</span>")(0), ">")(3), "")
    
24.         Cells(k, 2) = Split(Split(Split(arr, "</span>")(1), ">")(1), "")
    
25.         Cells(k, 3) = Split(Split(Split(arr, "</span>")(2), ">")(4), "")
    
26.         Cells(k, 4) = Split(Split(Split(arr, "</span>")(3), ">")(2), "")
    
27.         Next r
    
28.         Next j
    
29. 
    
30.     Application.ScreenUpdating = True
    
31.     MsgBox " TaxNews：Complete!" & vbCrLf & vbCrLf & "用时:" & " " & Timer - t & "秒", vbInformation, "Warm Tips"
    
32. End Sub
    

复制代码

翻页自己再改改

wbperfect

+附件----------

wu282815876

wbperfect 发表于 2020-1-10 16:46
+附件----------

大佬，可以多提取几页吗，可以给这些附上对应的超链接吗

wu282815876

嘿嘿嘿 谢谢大佬

wbperfect

wu282815876 发表于 2020-1-10 16:53
大佬，可以多提取几页吗，可以给这些附上对应的超链接吗

页码自定义收入  链接详见附件

Sub text()
    Dim str$, html, url$, r%, arr, j%
    Application.ScreenUpdating = Fals
   
    Set html = CreateObject("htmlfile")
    K = 1
    For j = 1 To 5 '页码自定义修改
     If j = 1 Then
        url = "http://ggzy.hefei.gov.cn/jyxx/002001/002001001/moreinfo_jyxxgg2.html"
        Else
        url = "http://ggzy.hefei.gov.cn/jyxx/002001/002001001/" & j & ".html"
     End If
        With CreateObject("WinHttp.WinHttpRequest.5.1")
            .Open "GET", url, False
            .setRequestHeader "cookie", "fontZoomState=0"
            .setRequestHeader "Referer", "http://ggzy.hefei.gov.cn/jyxx/002001/002001001/moreinfo_jyxxgg2.html"
            .send
            str = .responseText
          End With
          Debug.Print str
        For r = 0 To 19
        K = K + 1
        arr = Split(str, "</li>")(r)
     If r = 0 Then
        Cells(K, 1) = Split(Split(Split(Split(arr, "</span>")(0), "】")(0), "【")(1), "")
        Cells(K, 5) = Split(Split(Replace(Split(Split(arr, "</span>")(0), "title=")(0), """", ""), "href=")(5), "")
        Cells(K, 5) = "http://ggzy.hefei.gov.cn" & Cells(K, 5)
        Else
        Cells(K, 1) = Split(Split(Split(Split(arr, "</span>")(0), "】")(0), "【")(1), "")
        Cells(K, 5) = Split(Split(Replace(Split(Split(arr, "</span>")(0), "title=")(0), """", ""), "href=")(1), "")
        Cells(K, 5) = "http://ggzy.hefei.gov.cn" & Cells(K, 5)
     End If
        Cells(K, 2) = Split(Split(Split(Split(arr, "</span>")(1), "】")(0), "【")(1), "")
        Cells(K, 3) = Split(Split(Split(arr, "</span>")(2), ">")(4), "")
        Cells(K, 4) = Split(Split(Split(arr, "</span>")(3), ">")(2), "")
        
  
        Next r
        Next j
        
    Application.ScreenUpdating = True
    MsgBox " Complete!" & vbCrLf & vbCrLf & "用时:" & " " & Timer - t & "秒", vbInformation, "Warm Tips"
End Sub

wbperfect

多页码 +链接

wu282815876

http://www.cebpubservice.com/ctpsp_iiss/searchbusinesstypebeforedooraction/getSearch.do  求助大佬，这个页变了，但是网址不变的这种信息如何抓取

wu282815876

wbperfect 发表于 2020-1-13 14:03
页码自定义收入  链接详见附件

Sub text()

http://www.cebpubservice.com/ctpsp_iiss/searchbusinesstypebeforedooraction/getSearch.do  大佬这个网站，页码变 但是网址不变的 怎么抓信息呀

wu282815876

哦豁 哦豁 求帮忙