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

標題: [發問] 請高手指導修正"即時估計淨值" [打印本頁]

作者: lcctno 時間: 2016-3-15 09:15 標題: 請高手指導修正"即時估計淨值"

本帖最後由 lcctno 於 2016-3-15 09:17 編輯

這是元大寶來ETF淨值的網址
http://www.yuantaetfs.com/#/RtNav/Index

如圖這是元大寶來網路看到的ETF淨值
[attach]23449[/attach]

這圖是本來今天之前的即時淨值圖
[attach]23450[/attach]

這圖是我目前無法使用的即時淨值圖
[attach]23451[/attach]

我嘗試了很久無法弄好VBA 麻煩高手幫我解決問題謝謝
附件:即時淨值.zip
[attach]23452[/attach]

作者: lcctno 時間: 2016-3-15 09:35

本帖最後由 lcctno 於 2016-3-15 09:38 編輯

這是即時淨值VBA 剛剛漏了寫麻煩高手幫我修正成可正常使用的EXCELL表格

Sub 即時淨值()

Dim E As Object, myItems As Object, myitem
With CreateObject("InternetExplorer.Application")
      .Visible = True
      .Navigate "http://www.yuantaetfs.com/#/RtNav/Index"

      Application.Wait Now + #12:00:03 AM# '有錯在開啟

      Set myItems = .Document.getElementsByTagName("button")
      For Each myitem In myItems

      'Application.Wait Now + #12:00:00 AM# '有錯在開啟

         If myitem.Name = "Agree" Then

            myitem.Click '按下送出查詢按鈕

         End If
      Next

      Set E = .Document.getElementsByTagName("TABLE")(21)
      .Document.body.innerHTML = E.outerHTML
      .ExecWB 17, 2    '  Select All
      .ExecWB 12, 2    '  Copy selection
      With ActiveSheet
         '.Cells.Clear
         .[A1].Select
         .PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False, NoHTMLFormatting:=True
      End With
      .Quit       '關閉網頁
End With

End Sub

作者: joey0415 時間: 2016-3-15 12:01

您試試看

Sub 即時淨值()
Application.ScreenUpdating = False
Cells.Delete
Dim E As Object, myItems As Object, myitem
With CreateObject("InternetExplorer.Application")
.Visible = True
.Navigate "http://www.yuantaetfs.com/#/RtNav/Index"
Application.Wait Now + #12:00:03 AM# '有錯在開啟
Set myItems = .Document.getElementsByTagName("button")
For Each myitem In myItems
'Application.Wait Now + #12:00:00 AM# '有錯在開啟
If myitem.Name = "Agree" Then
myitem.Click '按下送出查詢按鈕
End If
Next
Set E = .Document.getElementsByTagName("TABLE")(22)
.Document.body.innerHTML = E.outerHTML
.ExecWB 17, 2 ' Select All
.ExecWB 12, 2 ' Copy selection
With ActiveSheet
'.Cells.Clear
.[A1].Select
.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False, NoHTMLFormatting:=True
End With
.Quit '關閉網頁
End With
x = Cells(Rows.Count, 1).End(xlUp).Row
For A = x To 6 Step -1
If Cells(A, 3) = "" Then
Rows(A).Delete
End If
Next
Application.ScreenUpdating = True
End Sub

複製代碼

回復 2# lcctno

作者: lcctno 時間: 2016-3-15 12:30

回復 3# joey0415
感謝您的幫忙
但會缺台灣50 如圖
[attach]23455[/attach]

作者: joey0415 時間: 2016-3-15 13:20

回復 4# lcctno

小修改一下，應該可以

Sub 即時淨值()
Application.ScreenUpdating = False
Cells.Delete
Dim E As Object, myItems As Object, myitem
With CreateObject("InternetExplorer.Application")
.Visible = True
.Navigate "http://www.yuantaetfs.com/#/RtNav/Index"
Application.Wait Now + #12:00:03 AM# '有錯在開啟
Set myItems = .Document.getElementsByTagName("button")
For Each myitem In myItems
'Application.Wait Now + #12:00:00 AM# '有錯在開啟
If myitem.Name = "Agree" Then
myitem.Click '按下送出查詢按鈕
End If
Next
Set E = .Document.getElementsByTagName("TABLE")(21)
.Document.body.innerHTML = E.outerHTML
.ExecWB 17, 2 ' Select All
.ExecWB 12, 2 ' Copy selection
With ActiveSheet
'.Cells.Clear
.[A1].Select
.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False, NoHTMLFormatting:=True
End With
.Quit '關閉網頁
End With
x = Cells(Rows.Count, 2).End(xlUp).Row
For A = x To 6 Step -1
If Cells(A, 4) = "" Then
Rows(A).Delete
End If
Next
Columns(1).Delete
Application.ScreenUpdating = True
End Sub

複製代碼

作者: lcctno 時間: 2016-3-15 13:29

回復 5# joey0415
目前還是缺台灣50 我今日上傳的語法就會缺台灣50 但之前的有台灣50
您請看圖最上方有短少的台灣50資料

[attach]23456[/attach]

作者: joey0415 時間: 2016-3-15 20:38

回復 6# lcctno
你再試試

Sub 即時淨值()
Application.ScreenUpdating = False
Cells.Delete
Dim E As Object, myItems As Object, myitem
With CreateObject("InternetExplorer.Application")
.Visible = True
.Navigate "http://www.yuantaetfs.com/#/RtNav/Index"
Application.Wait Now + #12:00:03 AM# '有錯在開啟
Set myItems = .Document.getElementsByTagName("button")
For Each myitem In myItems
'Application.Wait Now + #12:00:00 AM# '有錯在開啟
If myitem.Name = "Agree" Then
myitem.Click '按下送出查詢按鈕
End If
Next
Set r = .Document.All.tags("table")(22).Rows
n = Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To r.Length - 1
For j = 0 To r(i).Cells.Length - 2
Cells(i + n + 1 - 3, j + 1) = r(i).Cells(j).innerText
Next j
Next
x = Cells(Rows.Count, 1).End(xlUp).Row
For A = x To 1 Step -1
If Cells(A, 3) = "" Then
Rows(A).Delete
End If
Next
.Quit
End With
Application.ScreenUpdating = True
End Sub

複製代碼

作者: lcctno 時間: 2016-3-15 21:18

本帖最後由 lcctno 於 2016-3-15 21:30 編輯

回復 7# joey0415
回復: 高手正常了
可以分享您的解決方法嗎?
為何我貼的語法台灣50會不正常無法全部顯視(只能顯視部分的資訊)
您可不可以幫我上傳的部分您修改的地方說明一下是否能將"資料時間"能顯示出來
謝謝您的辛苦了

作者: lcctno 時間: 2016-3-16 09:18

本帖最後由 lcctno 於 2016-3-16 09:23 編輯

回復 7# joey0415
現在有個比較大的問題是
只要一更新淨值其他使用該資訊的連結就會發生問題 (請看更新後)
您可不可以將VBA改為我最原始的樣子
但要有0050的全部資訊
不用需要完美的再排序謝謝您了

若不缺0050 這是我可以用的即時淨值圖
[attach]23464[/attach]

更新前
[attach]23462[/attach]

更新後
[attach]23463[/attach]

附件
[attach]23461[/attach]

歡迎光臨麻辣家族討論版版 (http://forum.twbts.com/)