麻辣家族討論版版 - Powered by Discuz! Board

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

複製代碼

For i = 1 To Max_Id
.Navigate ID & i

複製代碼

For i = 1 To 9999
.Navigate ID & i

複製代碼

Sub TEST()
Dim UL$, STR, FN&, j&, k%, Arr, X&, N&, TM
TM = Time
[Sheet1!A:E].ClearContents: [F1] = ""
[Sheet1!A1:E1] = Array("ID", "姓名", "電話", "傳真", "地址")
　
'↓取得〔總頁數〕
STR = 網頁原始碼("http://www.tyland.org.tw/pg.asp?theme=11")
STR = Split(Split(STR, ">最後一頁")(0), "absolutepage=")
FN = STR(UBound(STR))
　
'↓取得〔最大ＩＤ編號〕
UL = "http://www.tyland.org.tw/pg.asp?theme=11&kinds=2&area=&search=o&review=&model=1&meid=&absolutepage="
STR = 網頁原始碼(UL & FN)
STR = Split(STR, "view-m.asp?mno=")
FN = Split(STR(UBound(STR)), "'>")(0)
　
'↓開始擷取資料（含所有資料）
ReDim Arr(1 To FN, 1 To 5)
For j = 1 To FN
　　Application.StatusBar = "■■■■■■資料擷取中：" & j & "／" & FN
　　STR = 網頁原始碼("http://www.tyland.org.tw/view-m.asp?mno=" & j)
　　If Len(STR) = 0 Then GoTo 101
　　X = InStr(STR, "<li>會　　號：")
　　If X = 0 Then GoTo 101
　　STR = Split(Mid(STR, X), "</li>")
　
　　N = N + 1
　　For k = 1 To 4 'ID.姓名.電話.傳真
　　　　Arr(N, k) = Trim(Split(STR(k - 1), "：")(1))
　　Next k
　　Arr(N, 5) = Trim(Split(STR(6), "：")(1)) '地址
101: Next j
　
If N > 0 Then [A2:E2].Resize(N) = Arr
[Sheet1!F1] = Format(Time - TM, "hh:mm:ss")
Application.StatusBar = False
Beep
End Sub
　
　
'＝＝＝＝＝＝＝＝＝＝＝＝＝副程式
Function 網頁原始碼(xURL$) As String
On Error Resume Next
With CreateObject("MSXML2.XMLHTTP")
.Open "POST", xURL, False
.send
網頁原始碼 = .ResponseText
End With
On Error GoTo 0
End Function

複製代碼