Board logo

標題: [發問] 抓取多網頁資料 [打印本頁]
作者: msmplay    時間: 2020-1-10 10:48     標題: 抓取多網頁資料

需求：我需要３個資料【賣場名稱、賣場連結網址、價格】

使用工具：ie11
使用網址：https://www.findprice.com.tw/
人工匯整檔案：https://drive.google.com/file/d/1I1gRapjwq-y-RrBwS0kpDDDv4RNiUgkZ/view?usp=sharing

問題１：是否有什麼方式可以將網頁搜尋結果的多個網頁，一次抓取或轉存至同一excel檔內
例如：以上網頁搜尋『kd-55x8000g』，會出現10頁結果，目前做法為一頁一頁轉出至excel，再以人工的方式匯整成一個活頁，非常耗時
[attach]31632[/attach][attach]31633[/attach]

[attach]31634[/attach]



問題２：此匯出excel檔方式無法匯出每個賣場連結網址，是否有其方式也可以抓得到或轉出每個賣場連結網址呢？重點在於我需要３個資料【賣場名稱、賣場連結網址、價格】
[attach]31635[/attach]
作者: GBKEE    時間: 2020-4-14 18:36

回復 1# msmplay
程式碼複製在同一模組上
  1.     Option Explicit
  2.     Dim 圖片目錄 As String, 圖片數 As Double, 圖片名稱 As String
  3.     Sub Ex_抓取多網頁資料()
  4.     Dim I As Integer, ii As Integer, e As Object
  5.     Dim Search As String, IMG As Object, Span As Object, A As Object
  6.     Search = InputBox("kd-55x8000g", "請輸入要搜尋的字串")
  7.     If Search = "" Then MsgBox "沒有請輸入......": End
  8.     With CreateObject("InternetExplorer.Application")
  9.        ' .Visible = True
  10.         .Navigate "https://www.findprice.com.tw/"
  11.         Do While .Busy Or .readyState <> 4: DoEvents: Loop
  12.         .Document.GETELEMENTBYID("search").Value = Search  '**輸入要搜尋的字串
  13.         Do While .Busy Or .readyState <> 4: DoEvents: Loop
  14.         .Document.GETELEMENTBYID("tsbb").Click                           '**搜尋鍵
  15.         Do While .Busy Or .readyState <> 4: DoEvents: Loop
  16.         Set A = .Document.form1.ALL.TAGS("tbody")
  17.         If InStr(A(1).INNERTEXT, Search) = 0 Then                              '**沒有搜尋到
  18.             MsgBox vbLf & A(1).INNERTEXT
  19.                 GoTo Xquit
  20.         Else
  21.             工作表整理
  22.             Cells(1) = Trim(Split(A(1).INNERTEXT, ">")(0))
  23.             Cells(1, 2) = "價格"
  24.             Cells(1, 3) = "說明"
  25.         End If
  26.         I = 1
  27. NE:
  28.         Do While .Busy Or .readyState <> 4: DoEvents: Loop
  29.         Set e = .Document.GETELEMENTBYID("tbContent").ALL.TAGS("TR")
  30.         For ii = 1 To e.Length - 1
  31.             With e(ii).ALL
  32.                 Set A = .TAGS("A")(0)
  33.                 If Not A Is Nothing Then
  34.                     Set IMG = A.ALL.TAGS("IMG")(0)
  35.                     Set Span = .TAGS("SPAN")
  36.                     If Not IMG Is Nothing And Span.Length > 0 Then
  37.                         If Span(0).CLASSNAME = "rec-price-20" Then
  38.                             I = I + 1
  39.                             Cells(I, "b") = Trim(Span(0).INNERTEXT)
  40.                             Cells(I, "C") = Trim(IMG.Title)
  41.                             網路圖片 IMG.Href
  42.                             Ex_網頁資料 Cells(I, "a"), A.Href
  43.                         End If
  44.                     End If
  45.                 End If
  46.             End With
  47.         Next
  48.         '**下一頁   '<a id="pg-next" href="/g/kd-55x8000g/?i=3">下一頁 &gt;</a>
  49.         For Each e In .Document.ALL.TAGS("A")
  50.             If e.ID = "pg-next" Then
  51.                 e.Click              '下一頁 (按鍵)
  52.                 GoTo NE         '循環到下一頁
  53.             End If
  54.         Next
  55. Xquit:
  56.         .Quit        '關閉網頁
  57.     End With
  58.     Range("b:b").Columns.AutoFit
  59. End Sub
  60. Private Sub 工作表整理()
  61.         圖片目錄 = ThisWorkbook.Path & "\商品圖片\"
  62.         If Dir(圖片目錄, vbDirectory) = "" Then MkDir 圖片目錄   '**沒有圖片目錄則建立之
  63.         If Dir(圖片目錄 & "*.*") <> "" Then Kill 圖片目錄 & "\*.*"  '**圖片目錄下有檔案則刪除之
  64.         圖片數 = 0
  65.        Pictures.Delete                                                                              '**刪除工作表上的圖片
  66.         With Cells
  67.             .Clear
  68.             .Columns.AutoFit
  69.             .Rows.AutoFit
  70.              .WrapText = False
  71.             .HorizontalAlignment = xlCenter
  72.             .VerticalAlignment = xlCenter
  73.         End With
  74.         With Range("c:c")
  75.             .ColumnWidth = 40
  76.             .WrapText = True
  77.         End With
  78. End Sub
  79. Private Sub Ex_網頁資料(Rng As Range, Href As String)
  80.         With Rng
  81.             .ColumnWidth = 15
  82.             .RowHeight = 90
  83.         End With
  84.         With Pictures.Insert(圖片名稱)                               '**插入圖片
  85.             .ShapeRange.LockAspectRatio = msoFalse   '**不鎖定圖片的長寬比例
  86.             .top = Rng.top
  87.             .left = Rng.left
  88.             .Height = Rng.Height
  89.             .width = Rng.width
  90.             ActiveSheet.Hyperlinks.Add Anchor:=.ShapeRange.Item(1), Address:=Href            '***超連結
  91.     End With
  92. End Sub
  93. Private Sub 網路圖片(URL As String)
  94.     Dim Xml As Object               '用來取得網頁資料
  95.     Dim Stream  As Object        'As ADODB.stream   '用來儲存二進位檔案
  96.     On Error GoTo Url_err         '處理圖片網頁的錯誤
  97. Again:
  98.     Set Xml = CreateObject("Microsoft.XMLHTTP")
  99.     Set Stream = CreateObject("ADODB.stream")
  100.     Xml.Open "GET", URL, 0
  101.     Xml.send
  102.     With Stream
  103.         .Open
  104.         .Type = 1
  105.         .write Xml.ResponseBody
  106.        ' If Dir(商品圖片) <> "" Then Kill 商品圖片
  107.        圖片名稱 = 圖片目錄 & 圖片數 & ".jpg"
  108.        圖片數 = 圖片數 + 1
  109.         .SaveToFile (圖片名稱)
  110.         .Close
  111.     End With
  112.     Set Xml = Nothing
  113.     Set Stream = Nothing
  114.     Exit Sub
  115. Url_err:
  116.     URL = "https://th.bing.com/th/id/OIP.lmGYd5XOfu-zuoG1GZW-HAHaE8?w=256&h=171&c=7&o=5&dpr=1.2&pid=1.7"
  117.     GoTo Again
  118. End Sub
複製代碼




歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)