(不定期更新)使用VBA解決 excel web 查詢無法匯入、匯入太慢的股市資料

0分

1381樓

個人積分：0分

文章編號：88973113

Snare大師您好：
非常感謝您的提示，現在已經可以用XmlHttp下載上櫃每日收盤行情，可是速度好像不對，超過55秒比原來的QT慢。是不是我在哪裡出錯了？
嘗試用timer統計下載時間，但是ttt=timer和 Debug.Print "Html: " & (Timer – ttt) 沒有動作，煩請再指正。謝謝！

Sub GettpexHtml_m1380()

'Html下載測試_上櫃股票每日收盤行情

Dim wsResult As Worksheet
Dim wsSettings As Worksheet
Dim queryDate As Date
Dim Url As String
Dim success As Boolean
Dim Html As Object, XmlHttp As Object
Dim Table, YMD As String

Set wsResult = ThisWorkbook.Sheets("測試工作表")
Set wsSettings = ThisWorkbook.Sheets("設定主畫面")

Set Html = CreateObject("htmlfile")
Set XmlHttp = CreateObject("Msxml2.XMLHTTP")
Application.ScreenUpdating = False

'選取測試工作表
'Sheets("測試工作表").Select

queryDate = Sheets("設定主畫面").Range("G2").Value '使用查詢日期

'(AA) 格式化查詢日期為民國年/月/日格式

'Dim rocYear As Integer
'Dim rocMonth As Integer
'Dim rocDay As Integer

'rocYear = Year(queryDate) - 1911
'rocMonth = Month(queryDate)
'rocDay = Day(queryDate)

'Dim formattedDate As String ' 日期字串
'formattedDate = Format(rocYear, "000") & "/" & Format(rocMonth, "00") & "/" & Format(rocDay, "00")

'(BB) 將查詢日期西元年轉換成民國年並格式化成中文日期

Dim rocYear As Integer
rocYear = Year(queryDate) - 1911 ' 轉換成民國年

Dim formattedDate As String
formattedDate = rocYear & Format(queryDate, "/mm/dd") ' 中文日期格式民國年/月/日

' 顯示中文日期
MsgBox "formattedDate: " & formattedDate

Sheets("測試工作表").Cells.Clear

Dim ttt As Double
ttt = Timer

' 修改 URL
'Url = "https://www.tpex.org.tw/web/stock/aftertrading/otc_quotes_no1430/stk_wn1430_result.php?l=zh-tw&o=htm&d=113/01/10& "&se=EW&s=0,asc,0"
Url = "https://www.tpex.org.tw/web/stock/aftertrading/otc_quotes_no1430/stk_wn1430_result.php?l=zh-tw&o=htm&d=" & formattedDate & "&se=EW&s=0,asc,0"

With XmlHttp
.Open "GET", Url, False
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
.setRequestHeader "Cache-Control", "no-cache"
.setRequestHeader "Pragma", "no-cache"
.Send
Html.body.innerHtml = .responseText
Set Table = Html.all.tags("table")(0).Rows
End With

With Sheets("測試工作表")
.Cells.Clear
.Range("A:A").NumberFormatLocal = "@"

For i = 0 To Table.Length - 1
For j = 0 To Table(i).Cells.Length - 1
.Cells(i + 1, j + 1) = Table(i).Cells(j).innertext
Next j
Next i

If Err.Number = 0 Then
success = True ' 下載成功
Else
success = False ' 下載失敗
End If

On Error GoTo 0

If success Then
' 下載成功
MsgBox "已下載最新上櫃收盤價資料。"
Else
' 下載失敗
MsgBox "無法下載最新上櫃收盤價資料。", vbInformation

Exit Sub
End If

.Columns.AutoFit
.Columns("A:A").ColumnWidth = 16

End With

Debug.Print "Html:" & (Timer - ttt)

Application.ScreenUpdating = True
Set Html = Nothing
Set XmlHttp = Nothing

End Sub

snare

3127分

樓主

snare

個人積分：3127分

文章編號：88974354

Morten Hsu wrote:
超過55秒比原來的QT慢。是不是我在哪裡出錯了？

QT測速時，需要用沒查過的資料才準
它像上網一樣，有快取，有查過的會比較快

我測試差不多都在2秒左右(1380樓範例+您的程式碼)

(秒、查詢資料日期、什麼時間測試的)

自行比較一下程式碼吧(因為要測試您的程式碼，所以小改了一些地方)

點我看大圖

另外雖然沒什麼影響，您的網址打錯了

Morten Hsu

0分

1383樓

Morten Hsu

個人積分：0分

文章編號：88989402

非常感謝大師的指正，已經可以下載上櫃收盤價了，再次謝謝您。
我也套用同樣的寫法修改原本用QT的上市收盤價下載，不知是邏輯有問題還是設備的問題，下載速度為15.95秒。檢附完整程式碼，敬請指正。謝謝！
Sub GettwseHtml()

'Html下載測試_上市股票每日收盤行情

'Dim wsResult As Worksheet
'Dim wsSettings As Worksheet
Dim queryDate As Date
Dim Url As String
Dim success As Boolean
Dim Html As Object, XmlHttp As Object
Dim Table, YMD As String

'Set wsResult = ThisWorkbook.Sheets("測試工作表")
'Set wsSettings = ThisWorkbook.Sheets("設定主畫面")

Set Html = CreateObject("htmlfile")
Set XmlHttp = CreateObject("Msxml2.XMLHTTP")
Application.ScreenUpdating = False

'將西元年yyyy/mm/dd轉換成yyyymmdd的日期格式

Dim formattedDate As String ' 日期字串
'queryDate = Sheets("設定主畫面").Range("G2")
'formattedDate = Format(queryDate, "yyyymmdd")
formattedDate = "20240112"

Sheets("測試工作表").Cells.Clear

Dim ttt As Double
ttt = Timer

'修改下載網址 https://www.twse.com.tw/rwd/zh/afterTrading/MI_INDEX?date=20240112&type=ALLBUT0999&response=html
'Url="https://www.twse.com.tw/rwd/zh/afterTrading/MI_INDEX?date=" & Format(queryDate, "yyyymmdd") & "&type=ALLBUT0999&response=html"

Url = "https://www.twse.com.tw/rwd/zh/afterTrading/MI_INDEX?date=" & formattedDate & "&type=ALLBUT0999&response=html"

With XmlHttp
.Open "GET", Url, False
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
.Send

Html.body.innerHtml = .responseText
Set Table = Html.all.tags("table")(8).Rows
End With

With Sheets("測試工作表")
.Cells.Clear
.Range("A:A").NumberFormatLocal = "@"

For i = 0 To Table.Length - 1
For j = 0 To Table(i).Cells.Length - 1
.Cells(i + 1, j + 1) = Table(i).Cells(j).innertext
Next j
Next i

.Columns.AutoFit
.Columns("A:A").ColumnWidth = 16

End With

Debug.Print "Html_M1380: " & (Timer - ttt), formattedDate, Now()

Application.ScreenUpdating = True
Set Html = Nothing
Set XmlHttp = Nothing

End Sub

snare

3127分

樓主

snare

個人積分：3127分

文章編號：88993485

Morten Hsu wrote:
下載速度為15.95秒。檢附完整程式碼，敬請指正

原因不明，可試看看不同網路的情況，例如：改用手機上網
或不同電腦試試

我是用hinet ，在5個不同時間點測試，大約都在3秒左右
試了幾台電腦不同版本的excel，也差不多是3秒
也有可能是您試到某個時間區段，剛好是網站忙碌的時候

(您的程式碼一字未改測試的)

Morten Hsu

0分

1385樓

Morten Hsu

個人積分：0分

文章編號：88997902

非常感謝Snare大師實測。

Morten Hsu

0分

1386樓

Morten Hsu

個人積分：0分

文章編號：89025197

Snare大師您好：
參考您的範例我嘗試將QT下載上市收盤價改成html下載，部分程式碼如下：
Dim formattedDate As String ' 日期字串
queryDate = Sheets("設定主畫面").Range("G2")
formattedDate = Format(queryDate, "yyyymmdd")

Dim ttt As Double
ttt = Timer

'修改下載網址 https://www.twse.com.tw/rwd/zh/afterTrading/MI_INDEX?date=20240112&type=ALLBUT0999&response=html
'Url="https://www.twse.com.tw/rwd/zh/afterTrading/MI_INDEX?date=" & Format(queryDate, "yyyymmdd") & "&type=ALLBUT0999&response=html"

Url = "https://www.twse.com.tw/rwd/zh/afterTrading/MI_INDEX?date=" & formattedDate & "&type=ALLBUT0999&response=html"

With XmlHttp
.Open "GET", Url, False
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
.Send

Html.body.innerHtml = .responseText
Set Table = Html.all.tags("table")(8).Rows
End With

With Sheets("最新上市收盤價")
.Cells.Clear
.Range("A:A").NumberFormatLocal = "@"

On Error Resume Next

For i = 0 To Table.Length - 1
For j = 0 To Table(i).Cells.Length - 1
.Cells(i + 1, j + 1) = Table(i).Cells(j).innertext
Next j
Next i

On Error GoTo ErrorHandler ' 移至正確的位置

success = True ' 下載成功
MsgBox "成功下載最新上市收盤價資料。", vbInformation

.Columns.AutoFit
.Columns("A:A").ColumnWidth = 16

End With

Debug.Print "Html_上市: " & (Timer - ttt), formattedDate, Now()
Set Table已經指定是Table(8), 我如果想在同一張工作表下載Table(0), (6)和(8)，請問本棟大樓有樓層討論合併三份Table的參考範例嗎？請賜教，謝謝。

snare

3127分

樓主

snare

個人積分：3127分

文章編號：89025540

Morten Hsu wrote:
想在同一張工作表下載Table(0), (6)和(8)

寫在同一個sub裡面就行，其它程式碼請自行補上


sub test()


……………
……………
.Send
Html.body.innerHtml = .responseText
End With
……………
……………
       Set Table = Html.all.tags("table")(0).Rows
……………
……………
       .Cells(i + 1, j + 1)
……………
……………
       Set Table = Html.all.tags("table")(6).Rows
……………
……………
接著最後一列       .Cells(i + 1 + 最後一列+間隔幾列, j + 1)
……………
……………
       Set Table = Html.all.tags("table")(8).Rows
……………
……………
接著最後一列       .Cells(i + 1 + 最後一列+間隔幾列, j + 1)
……………
……………
或是3個都自訂位置        .Cells(R + 1, C + 1)

end sub

Morten Hsu

0分

1388樓

Morten Hsu

個人積分：0分

文章編號：89026367

感謝Snare大師回覆，我趕快試試看。
另外一個問題，原本用QT下載是9張Table都一起下載到工作表。現在變更下載方式，如果不挑特定Table，就像QT一樣全部下載，程式碼會不會比教簡單？

Morten Hsu

0分

1389樓

Morten Hsu

個人積分：0分

文章編號：89027587

Snare大師您好：
參照#1387的提示，完成如下：
Url = "https://www.twse.com.tw/rwd/zh/afterTrading/MI_INDEX?date=" & formattedDate & "&type=ALLBUT0999&response=html"

With XmlHttp
.Open "GET", Url, False
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
.Send

Html.body.innerHtml = .responseText
End With

Set Table = Html.all.tags("table")(0).Rows

With Sheets("最新上市收盤價")
.Cells.Clear
.Range("A:A").NumberFormatLocal = "@"

On Error Resume Next

For i = 0 To Table.Length - 1
For j = 0 To Table(i).Cells.Length - 1
.Cells(i + 1, j + 1) = Table(i).Cells(j).innertext
Next j
Next i

End With

Set Table = Html.all.tags("table")(6).Rows

With Sheets("最新上市收盤價")
'.Cells.Clear
.Range("A:A").NumberFormatLocal = "@"

On Error Resume Next

For i = 0 To Table.Length - 1
For j = 0 To Table(i).Cells.Length - 1
.Cells(i + 60, j + 1) = Table(i).Cells(j).innertext
Next j
Next i

End With

Set Table = Html.all.tags("table")(8).Rows

With Sheets("最新上市收盤價")
'.Cells.Clear
.Range("A:A").NumberFormatLocal = "@"

On Error Resume Next

For i = 0 To Table.Length - 1
For j = 0 To Table(i).Cells.Length - 1
.Cells(i + 80, j + 1) = Table(i).Cells(j).innertext
Next j
Next i

On Error GoTo ErrorHandler ' 移至正確的位置

success = True ' 下載成功
MsgBox "成功下載最新上市收盤價資料。", vbInformation

.Columns.AutoFit
.Columns("A:A").ColumnWidth = 16

End With

Debug.Print "Html_上市多表格: " & (Timer - ttt), queryDate, Now()

是可以正確下載指定表單，但是很耗時間，總共44.9296秒。不知道有沒有更快速的辦法，請賜教。謝謝！