Excel VBA 遇到網頁下拉式選單要如何變更選項

狐狸男孩
個人積分：2分
文章編號：65237954

2分

樓主

2017-07-29 17:20

各位大大
小弟想要用EXCEL VBA 自動抓取每日交易資料
網頁來源為 :
http://www.tpex.org.tw/web/emergingstock/historical/daily/EMdss007.php?l=zh-tw&f=EMdss007.20170728-C.csv

網頁的下拉式選單預設是每次顯示10筆資料，導致我無法抓到全部的資料，所以想請問各位大大，要如何變更下拉式選單為 "全部"的選項好讓我能夠一次抓到全部資料

Excel VBA 遇到網頁下拉式選單要如何變更選項

底下是我撰寫的程式，不知哪裡出錯，請各位大大幫忙指點迷津，謝謝

Sub IE()
Set objIE = CreateObject("InternetExplorer.Application")
Cells.ClearContents
With objIE
.Visible = False
.navigate "http://www.tpex.org.tw/web/emergingstock/historical/daily/EMdss007.php?l=zh-tw&f=EMdss007.20170728-C.csv"
Do While .ReadyState <> 4 Or .busy
DoEvents
Loop

.document.getElementsByName("EMdss007_result_length")(0).selectedindex = 0

Application.Wait (Now + TimeValue("0:00:05"))

Dim D As Object, i As Integer, URL As String
Set D = .document.getElementsByTagName("table")
ActiveSheet.Cells.Clear
For i = 0 To D.Length - 1
Ep i, D(i).outerHTML
Next
.Quit
End With
End Sub

Private Sub Ep(i As Integer, S As String)
Dim R
With CreateObject("InternetExplorer.Application")

.navigate "about:Tabs"
.Visible = True
.document.body[removed] = S
.ExecWB 17, 2
.ExecWB 12, 2

With ActiveSheet
R = IIf(.UsedRange.Rows.Count = 1, 1, .UsedRange.Rows.Count + 2)
.Cells(R, 1) = "第 " & i & " 個 Table"
.Cells(R, 1).EntireRow.Interior.Color = vbYellow
.UsedRange.Cells(R + 1, 1).Select
.PasteSpecial Format:="HTML", link:=False, DisplayAsIcon:=False, NoHTMLFormatting:=True
End With
.Quit
End With
End Sub

2017-07-29 17:20 發佈

文章關鍵字 Excel VBA 網頁選項選單

snare

snare
個人積分：3056分
文章編號：65239613

3056分

2樓

2017-07-29 20:47

看到有人回覆，別高興，我不是來給您答案的

提示：某文章 200

狐狸男孩

狐狸男孩
個人積分：2分
文章編號：65286058

2分

樓主

2017-08-02 23:12

多謝snare 大師的提點，小弟終於解決這個問題，而且抓取速度快多了，秉持著回饋的精神，小弟將寫好的程式碼po在底下，讓有需要的人也能夠參考

Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, _
ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long

Sub GetTwseCsv()

Dim Url, Target, TwseT86csv, Clipboard As Object, TwseT86 As Object
Set Clipboard = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
Set TwseT86 = CreateObject("scripting.filesystemobject")

On Error GoTo checkid

Target = "c:\excel\" '暫存目錄
If Dir(Target, vbDirectory) = "" Then MkDir Target
'注意，暫存目錄下的檔案，會在無任何提示下刪除
If Dir(Target & "*.*") <> "" Then Kill Target & "*.*"

Sheets("Sheet1").Cells.Clear
Application.ScreenUpdating = False

daytext = InputBox("日期(7碼數字)", , Format(Date, "yyyymmdd") - 19110000) + 19110000

Url = "http://www.tpex.org.tw/web/emergingstock/historical/daily/EMDaily_dl.php?l=zh-tw&f=EMdss007." & daytext & "-C.csv"
'請輸入資料網址'

ttt = Timer

URLDownloadToFile 0, Url, Target & "t86.csvv", 0, 0

With TwseT86.OpenTextFile(Target & "t86.csvv", 1)

TwseT86csv = Replace(.ReadAll, "=", "")
.Close
End With

If Len(TwseT86csv) = 2 Then
Sheets("Sheet1").Cells(1, 1) = "很抱歉，沒有符合條件的資料!"
Exit Sub
End If

With Clipboard
.SetText TwseT86csv
.PutInClipboard
End With

With Sheets("Sheet1")
.Cells(1, 1).Select
.PasteSpecial NoHTMLFormatting:=True
.Columns("A:A").TextToColumns DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, Comma:=True
.Columns.ColumnWidth = 10
.Columns("B:B").ColumnWidth = 17
.Columns("A:A").HorizontalAlignment = xlLeft
.Rows(2).WrapText = True

.Cells(1, 1).Select
Application.ScreenUpdating = True
'資料筆數，如果用在不同網站，請自行依資料格式修正
'MsgBox .Cells(1, 1) & vbNewLine & "資料筆數" & .Range("a1").CurrentRegion.Rows.Count - 9 & "筆" & vbNewLine & "使用時間" & Round(Timer - ttt, 2) & "秒", vbOKOnly, "下載完成"'
End With

Set Clipboard = Nothing
Set TwseT86 = Nothing

checkid:

If Err.Number <> 0 Then
Debug.Print Err.Description
End If

End Sub

從 APP 打開