想請教如何在網頁（非表格狀態）抓資料（特定字串）到EXCEL表單 - Excel程式區

GBKEE

超級版主 Rank: 8 Rank: 8

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

1^# 跳轉到 »

發表於 2015-9-25 08:32 | 顯示全部帖子

回復 1# kuhsuanchieh

試試看

Option Explicit
'頁數
Const 頁數網址 = "http://www.tyland.org.tw/pg.asp?theme=11&kinds=2&area=&search=o&review=&model=1&meid=&absolutepage="
'會號 ID
Const ID = "http://www.tyland.org.tw/view-m.asp?mno="
Dim Sh As Worksheet, Ie As Object
Sub Ex()
Ex現在會員名錄
Ex_所有會員資料
End Sub
Sub Ex現在會員名錄()
Dim i As Integer, xTable As Object, r As Integer
Set Ie = CreateObject("InternetExplorer.Application")
Set Sh = Sheets(1)
With Sh
.UsedRange.Clear
.[A1:E1] = Array("ID", "姓名", "電話", "傳真", "地址")
'.[A1:D1] = Array( "姓名", "電話", "傳真", "地址")
.Activate
End With
With CreateObject("InternetExplorer.Application")
' .Visible = True
For i = 1 To Max_Page
.Navigate 頁數網址 & i
Do While .Busy Or .readyState <> 4: DoEvents: Loop
Set xTable = .Document.all.tags("table")(0).Rows
Application.StatusBar = 頁數網址 & i & " 載入..."
For r = 1 To xTable.Length - 1
Ex_現在會員資料 ID & xTable(r).Cells(1).INNERTEXT
Next
Next
.Quit
End With
Ie.Quit
Set Ie = Nothing
End Sub
Sub Ex_現在會員資料(URL As String)
Dim ID As String, i As Integer, E As Variant, ii As Integer, t As Variant, AR()
ID = "http://www.tyland.org.tw/view-m.asp?mno="
AR = Array(0, 1, 2, 3, 6) 'AR = Array( 1, 2, 3, 6) 不要"ID"
With Ie
' .Visible = True
.Navigate URL
Do While .Busy Or .readyState <> 4: DoEvents: Loop
t = Split(.Document.BODY.INNERTEXT, vbLf) '網頁的文字,vbLf 切割為陣列
With Sh.Range("A" & Rows.Count).End(xlUp).Offset(1)
.Select '可不用
For ii = 0 To 4
.Cells(1, ii + 1) = Split(t(AR(ii)), "：")(1)
Next
End With
End With
End Sub
Function Max_Page() As Integer '傳回會員名錄的總頁數
Dim E As Object
With CreateObject("InternetExplorer.Application")
' .Visible = True
.Navigate "http://www.tyland.org.tw/pg.asp?theme=11"
Do While .Busy Or .readyState <> 4: DoEvents: Loop
For Each E In .Document.all.tags("A")
If InStr(E.INNERTEXT, "最後一頁") Then
Max_Page = Replace(E.href, 頁數網址, "") '網頁字串最後的數字
Exit For
End If
Next
.Quit '關閉網頁
End With
End Function
'****************************************************
Sub Ex_所有會員資料()
Dim i As Integer, E As Variant, ii As Integer, t As Variant, AR()
Dim Sh As Worksheet
Set Sh = Sheets(2)
With Sh
.UsedRange.Clear
.[A1:E1] = Array("ID", "姓名", "電話", "傳真", "地址")
'.[A1:D1] = Array( "姓名", "電話", "傳真", "地址")
.Activate
End With
AR = Array(0, 1, 2, 3, 6) 'AR = Array( 1, 2, 3, 6) '不要"ID"
With CreateObject("InternetExplorer.Application")
' .Visible = True
For i = 1 To Max_Id
.Navigate ID & i
Do While .Busy Or .readyState <> 4: DoEvents: Loop
Application.StatusBar = ID & i & " 載入..."
t = Split(.Document.BODY.INNERTEXT, vbLf)
If UBound(t) > -1 Then
With Sh.Range("A" & Rows.Count).End(xlUp).Offset(1)
.Select '可不用
For ii = 0 To 4 'For ii = 0 To 3 '不要"ID
.Cells(1, ii + 1) = Split(t(AR(ii)), "：")(1)
Next
End With
End If
Next
.Quit
End With
End Sub
Function Max_Id() As Integer '查找最新會員的會號
Dim E As Object
With CreateObject("InternetExplorer.Application")
' .Visible = True
.Navigate "http://www.tyland.org.tw/pg.asp?theme=11"
Do While .Busy Or .readyState <> 4: DoEvents: Loop
For Each E In .Document.all.tags("A")
If InStr(E.INNERTEXT, "最後一頁") Then
E.Click '按下 "最後一頁"
Exit For
End If
Next
Do While .Busy Or .readyState <> 4: DoEvents: Loop
Set E = .Document.all.tags("table")(0).Rows
Max_Id = E(E.Length - 1).Cells(1).INNERTEXT '最新會員的會號
.Quit '關閉網頁
End With
End Function