[發問] 抓取多網頁資料

msmplay

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

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

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

下載 (8.15 KB)

2020-1-10 10:36

下載 (5.46 KB)

2020-1-10 10:36

下載 (232.75 KB)

2020-1-10 10:36

問題２：此匯出excel檔方式無法匯出每個賣場連結網址，是否有其方式也可以抓得到或轉出每個賣場連結網址呢？重點在於我需要３個資料【賣場名稱、賣場連結網址、價格】

下載 (211.9 KB)

2020-1-10 10:43

GBKEE

回復 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

複製代碼