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

標題: [發問] 請問能否將2個VBA巨集合併成1個VBA巨集 [打印本頁]

作者: lcctno 時間: 2015-7-23 21:05 標題: 請問能否將2個VBA巨集合併成1個VBA巨集

本帖最後由 lcctno 於 2015-7-23 21:06 編輯

我是初學者網路上找了數天但一直找不到方法請高手們拉我一把謝謝

VBA巨集.1
Sub 即時淨值()
Dim E As Object, myItems As Object, myitem
With CreateObject("InternetExplorer.Application")
      .Visible = True
      .Navigate "http://www.yuantaetfs.com/#/RtNav/Index"
      Do While .Busy Or .readyState <> 4: DoEvents: Loop
      'Application.Wait Now + #12:00:01 AM# '有錯在開啟
      Set myItems = .Document.getElementsByTagName("button")
      For Each myitem In myItems
         If myitem.Name = "Agree" Then
            myitem.Click                            '按下送出查詢按鈕
         End If
      Next
      Application.Wait Now + #12:00:01 AM#
      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
Range("L1:Q19").Select
Selection.ClearContents
      Range("D16:D17").Select
With Selection.Interior
      .ColorIndex = 35
      .Pattern = xlSolid
End With
End Sub

VBA巨集 2
Sub 國內指數()
Dim E As Object, myItems As Object, myitem
With CreateObject("InternetExplorer.Application")
      .Visible = True
      .Navigate "http://www.yuantaetfs.com/#/Home/Index"
      Do While .Busy Or .readyState <> 4: DoEvents: Loop
      'Application.Wait Now + #12:00:01 AM# '有錯在開啟
      Set myItems = .Document.getElementsByTagName("button")
      For Each myitem In myItems
         If myitem.Name = "Agree" Then
            myitem.Click                            '按下送出查詢按鈕
         End If
      Next
      Application.Wait Now + #12:00:01 AM#
      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
         .[A27].Select
         .PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False, NoHTMLFormatting:=True
      End With
      .Quit       '關閉網頁
      End With
      Range("A39:E39").Select
Selection.ClearContents
      Range("C27:C28").Select
With Selection.Interior
      .ColorIndex = 35
      .Pattern = xlSolid
End With
End Sub

作者: Min 時間: 2015-7-25 00:22

這樣嗎? 呵呵呵~ 不是很懂您想要的...

sub run_all()
call 即時淨值()
call 國內指數()
end sub

作者: lcctno 時間: 2015-7-25 06:57

回復 2# Min

感謝您熱心的回覆但您這樣豈不是又增加了1個句集變成3個巨集了
我是希望能夠簡化成一個巨集就能包含那2個巨集的動做且功能不變

作者: GBKEE 時間: 2015-7-25 14:01

回復 3# lcctno
試試看

Option Explicit
Sub Ex()
Dim E As Object, Ar(), i As Integer
Ar = Array("http://www.yuantaetfs.com/#/RtNav/Index", "http://www.yuantaetfs.com/#/Home/Index")
'Ar = Array(網址:即時淨值,網址:國內指數) 網址置入陣列
ActiveSheet.UsedRange.Clear
For i = 0 To 1
With CreateObject("InternetExplorer.Application")
.Visible = True
.Navigate Ar(i)
Do While .Busy Or .readyState <> 4: DoEvents: Loop
If i = 0 Then '國內指數:不需按下同意鍵
Do
Set E = .Document.getElementByid("Agree")
Loop Until Not E Is Nothing
E.Click
End If
Do
Do
Set E = .Document.getElementsByTagName("TABLE")(21 + i)
'即時淨值第21個 "TABLE" ,'國內指數第22個 "TABLE"
Loop Until Not E Is Nothing
Loop Until E.all.Length >= IIf(i = 0, 431, 150) '
.Document.body.innerHTML = E.outerHTML
.ExecWB 17, 2 ' Select All
.ExecWB 12, 2 ' Copy selection
With ActiveSheet
.Range("A" & IIf(i = 0, 1, 27)).Select
.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False, NoHTMLFormatting:=True
With .Range(IIf(i = 0, "D16:D17", "C27:C28")).Interior
.ColorIndex = 35
.Pattern = xlSolid
End With
End With
.Quit '關閉網頁
End With
Next
End Sub

複製代碼

作者: lcctno 時間: 2015-7-25 23:40

回復 4# GBKEE

感謝您的幫助但我費了些時間還是無法解決問題問題如下希望不是大問題再次的謝謝您的幫助

1.會卡住
[attach]21480[/attach]

2.錯誤訊息
[attach]21481[/attach]

3.偵錯
[attach]21482[/attach]

作者: GBKEE 時間: 2015-7-26 07:28

本帖最後由 GBKEE 於 2015-7-26 07:32 編輯

回復 5# lcctno

IE 為何會中斷連繫? Ie8 很順暢的,ADSL 5M/384K
請告知網址是 i=0 即時淨值, i=1國內指數
如會中斷連繫這裡就會了

Do
Set E = .Document.getElementsByTagName("TABLE")(21 + i)
'即時淨值第21個 "TABLE" ,'國內指數第22個 "TABLE"
Loop Until Not E Is Nothing

複製代碼

修改試試

If i = 0 Then '國內指數:不需按下同意鍵
Do
Set E = .Document.getElementByid("Agree")
Loop Until Not E Is Nothing
E.Click
Do While .Busy Or .readyState <> 4: DoEvents: Loop
End If

複製代碼

作者: lcctno 時間: 2015-7-26 08:23

回復 6# GBKEE

1.應該不是下載或上傳速度的問題我是使用中華電信光世代上網的

2.應該是我過程敘述的不好我再敘述的清楚一點
當執行該巨集後 EXCELL檔內並未載入任何東西空白一片當下只發生自動開啟IE11 停在"5樓的圖1.會卡住" 當我關掉IE後就出現 "圖2.錯誤訊息" 圖3.是偵錯後的截圖

再次的感謝您的用心的幫助希望您看懂初學者的我在敘述什麼

作者: no3-taco 時間: 2015-7-26 09:22

本帖最後由 no3-taco 於 2015-7-26 09:24 編輯

先加入程式碼裡面那兩行，修改完後跑一次
應該會出現兩次訊息框，記住數字然後改
E.all.Length >= IIf(i = 0, 431, 150) '第一次出現數字替換431 ,第二次出現數字替換150

無誤後,插入的那兩行就可以刪掉了
不曉得是不是ie版本不同的關係

'.Visible = True '先隱藏
Dim Atime: Atime = Timer '加入這裡######_1
Do
Do
Set E = .document.getElementsByTagName("TABLE")(21 + i)
'即時淨值第21個 "TABLE" ,'國內指數第22個 "TABLE"
Loop Until Not E Is Nothing
If Timer - Atime > 5 Then MsgBox E.all.Length: Exit Do '加入這裡######_2
Loop Until E.all.Length >= IIf(i = 0, 431, 150) '跑過一次後要修改的地方

複製代碼

作者: azrael19 時間: 2015-7-26 09:41

回復 GBKEE

1.應該不是下載或上傳速度的問題我是使用中華電信光世代上網的

2.應該是我過程敘述的不 ...
lcctno 發表於 2015-7-26 08:23

試試看...

Option Explicit
Sub Ex()
Dim E As Object, Ar(), i As Integer
Ar = Array("http://www.yuantaetfs.com/#/RtNav/Index", "http://www.yuantaetfs.com/#/Home/Index")
'Ar = Array(網址:即時淨值,網址:國內指數) 網址置入陣列
ActiveSheet.UsedRange.Clear
For i = 0 To 1
With CreateObject("InternetExplorer.Application")
.Visible = True
.Navigate Ar(i)
Do While .Busy Or .readyState <> 4: DoEvents: Loop
If i = 0 Then '國內指數:不需按下同意鍵
Do
Set E = .Document.getElementByid("Agree")
Loop Until Not E Is Nothing
E.Click
End If
Do
Do
Set E = .Document.getElementsByTagName("TABLE")(21 + i)
'即時淨值第21個 "TABLE" ,'國內指數第22個 "TABLE"
Loop Until Not E Is Nothing
'Loop Until E.all.Length >= IIf(i = 0, 431, 150) '
Loop Until 0 < InStr(1, E.outerHTML, IIf(i = 0, "基本資料", "台灣加權股價指數")) '改用相關字串確認是否有資料
.Document.body.innerHTML = E.outerHTML
.ExecWB 17, 2 ' Select All
.ExecWB 12, 2 ' Copy selection
With ActiveSheet
.Range("A" & IIf(i = 0, 1, 27)).Select
.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False, NoHTMLFormatting:=True
With .Range(IIf(i = 0, "D16:D17", "C27:C28")).Interior
.ColorIndex = 35
.Pattern = xlSolid
End With
End With
.Quit '關閉網頁
End With
Next
End Sub

複製代碼

作者: GBKEE 時間: 2015-7-26 10:28

本帖最後由 GBKEE 於 2015-7-27 09:53 編輯

回復 7# lcctno

當下只發生自動開啟IE11 停在"5樓的圖1.
此程式執行後會回到VBA編輯視窗,並打開'即時運算"的視窗
請第一個STOP 之後按下F5
如停留在VBA編輯視窗,"即時運算"一直有字串出現,代表程式一直在等後IE的資料,是IE 的問題
**請耐心等候到下一個 STOP 之後按下F5 **

Option Explicit
Sub Ex()
Dim E As Object, Ar(), i As Integer
Ar = Array("http://www.yuantaetfs.com/#/RtNav/Index", "http://www.yuantaetfs.com/#/Home/Index")
'Ar = Array(網址:即時淨值,網址:國內指數) 網址置入陣列
ActiveSheet.UsedRange.Clear
For i = 0 To 1
With CreateObject("InternetExplorer.Application")
.Visible = True
.Navigate Ar(i)
Do While .Busy Or .readyState <> 4: DoEvents: Loop
If i = 0 Then '國內指數:不需按下同意鍵
Do
Set E = .Document.getElementByid("Agree")
Loop Until Not E Is Nothing
E.Click
End If
.Visible = False
Application.VBE.MainWindow.Visible = True
Application.VBE.Windows("即時運算").Visible = True
Stop '之後按下F5
Do
Do
Set E = .Document.getElementsByTagName("TABLE")(21 + i)
'即時淨值第21個 "TABLE" ,'國內指數第22個 "TABLE"
Debug.Print i, "e Is Nothing ->", E Is Nothing
Loop Until Not E Is Nothing
Debug.Print i, "e Is Nothing ->", E Is Nothing, "e.all.Length", E.all.Length
Loop Until E.all.Length >= IIf(i = 0, 431, 150) '
Stop '之後按下F5
Application.VBE.Windows("即時運算").Visible = False
Application.VBE.MainWindow.Visible = False
.Document.body.innerHTML = E.outerHTML
.ExecWB 17, 2 ' Select All
.ExecWB 12, 2 ' Copy selection
With ActiveSheet
.Range("A" & IIf(i = 0, 1, 27)).Select
.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False, NoHTMLFormatting:=True
With .Range(IIf(i = 0, "D16:D17", "C27:C28")).Interior
.ColorIndex = 35
.Pattern = xlSolid
End With
End With
.Quit '關閉網頁
End With
Next
End Sub

複製代碼

作者: lcctno 時間: 2015-7-26 10:30

回復 9# azrael19

可以正常了
感謝您的用心這樣就可以正常顯示2組合併的巨集

作者: lcctno 時間: 2015-7-26 10:51

回復 10# GBKEE
無法執行(原因:我是菜鳥無能力修改完成)
1 語法錯誤
[attach]21485[/attach]

2.錯誤內容
[attach]21486[/attach]

感謝您熱心的參與謝謝您

作者: lcctno 時間: 2015-7-26 11:13

回復 9# azrael19

有一個延伸的問題能否判讀如附圖內右端整排資料之漲或跌
[attach]21487[/attach]

或可將實際之箭頭方向一併呈現我在用IF判斷

謝謝您

作者: lcctno 時間: 2015-7-26 12:09

回復 8# no3-taco
由於等網站對菜鳥的每小時只能回覆3次的限制故晚了回覆

由於個人初學巨集沒能力組合複雜的東西不過還好有熱心的高手子9樓)已解決了我的問題
還是非常感謝您熱心的參與回復謝謝您

作者: azrael19 時間: 2015-7-26 21:53

回復 azrael19

有一個延伸的問題能否判讀如附圖內右端整排資料之漲或跌

或可將實際之箭頭方向一 ...
lcctno 發表於 2015-7-26 11:13

用原本的方式我還不知道要怎麼做，如果你的需求只是要抓資料，下面是另一種方式你試試看...

Option Explicit
Option Base 1
Sub Ex()
Dim HEAD As Variant, PARAM As Variant, PA As Variant, AR As Variant, v As Variant
Dim i As Integer, j As Integer, k As Integer
Dim s As String, ErrDescription As String
Dim objCol As Object
'參數 : 網址,表頭放置位址,資料放置儲存格位址,標註顏色儲存格位址
PARAM = [{"http://www.yuantaetfs.com/api/RtNav","B1","B5","D16:D17"; "http://www.yuantaetfs.com/Home/IndexPrice","","B27","C27:C28"}]
'資料表頭陣列字串
HEAD = Array("{""資料時間"","""","""","""","""","""","""","""","""","""","""","""","""","""","""";" & _
"""基本資料"","""",""淨值"","""","""","""",""市價"","""","""","""",""折溢價"","""",""初級市場"","""",""基金"";" & _
"""股票"",""基金"",""昨收"",""預估"",""漲跌"",""漲跌幅"",""昨收"",""最新"",""漲跌"",""漲跌幅"",""折溢價"",""幅度"",""可否"",""可否"",""營業日"";" & _
"""代碼"",""名稱"",""淨值"",""淨值"","""","""",""市價"",""市價"","""","""","""","""",""申購"",""贖回"",""""}", "")
'Regular Expression
PA = Array("{""fundId"":""[\d]+"",""etfId"":""(.+?)"",""name"":""(.+?)"",""ename"":""[^""]*"",""yestNav"":(.+?),""nav"":(.+?),""navFluct"":(.+?),""yestPrice"":(.+?),""price"":(.+?),""priceFluct"":(.+?),""yestIndex"":(.+?),""index"":(.+?),""indexFluct"":(.+?),""updateTime"":""(.+?)"",""AllowMark"":""(.+?)"",""RedemMark"":""(.+?)"",""BussMark"":""(.+?)"",[^}]+}", _
"{""fund_id"":null,""IndexCode"":""[^""]*"",""IndexName"":""([^""]+)"",""IndexEName"":""[^""]*"",""crncy"":""[^""]*"",""area"":""D"",""DayDate"":""[^""]*"",""Close"":(.+?),""yestClose"":(.+?),""Diff"":(.+?)}")
ActiveSheet.UsedRange.ClearContents
For i = LBound(PARAM) To UBound(PARAM)
'抓取JSON資料
With CreateObject("WinHttp.WinHttpRequest.5.1")
.Open "GET", PARAM(i, 1), False
.send
If 200# <> .Status Then
ErrDescription = "網頁讀取失敗!"
GoTo Catch
End If
s = .responseText
End With
With ActiveSheet
If "" <> PARAM(i, 2) Then
'放置表頭資料
AR = Application.Evaluate(HEAD(i))
.Range(PARAM(i, 2)).Resize(UBound(AR, 1), UBound(AR, 2)).Value = AR
Erase AR
End If
If "" <> PA(i) Then
'解析JSON字串中所需資料
With CreateObject("VBScript.RegExp")
.Global = True
.Pattern = PA(i)
If False = .test(s) Then: GoTo Catch
Set objCol = Nothing
Set objCol = .Execute(s)
End With
If 0 = objCol.Count Then
ErrDescription = "資料格式解析錯誤!"
GoTo Catch
End If
ReDim AR(1 To objCol.Count, 1 To objCol(1).SubMatches.Count) As Variant
For j = 0 To objCol.Count - 1
For k = 0 To objCol(0).SubMatches.Count - 1
AR(j + 1, k + 1) = objCol(j).SubMatches(k)
Next k
Next
End If
Select Case i
Case 1
'重新排列及修正資料以符合網頁表格所呈現樣貌
For j = 0 To objCol.Count - 1
AR(j + 1, 9) = AR(j + 1, 8) '漲跌
AR(j + 1, 8) = AR(j + 1, 7) '最新市價
AR(j + 1, 7) = AR(j + 1, 6) '昨收市價
AR(j + 1, 6) = Round(AR(j + 1, 5) / AR(j + 1, 3), 4) '漲跌幅
AR(j + 1, 10) = Round(AR(j + 1, 9) / AR(j + 1, 7), 4) '漲跌幅
AR(j + 1, 11) = AR(j + 1, 8) - AR(j + 1, 4) '折溢價
AR(j + 1, 12) = Round(AR(j + 1, 11) / AR(j + 1, 4), 4) '幅度
Next j
.Range("B1").Value = "資料時間:" & Trim(objCol(0).SubMatches(11))
With .Range(PARAM(i, 3)).Resize(UBound(AR, 1), UBound(AR, 2))
'設定儲存格格式
v = Split("@,@,0.00,0.00,0.00,0.00%,0.00,0.00,0.00,0.00%,0.00,0.00%", ",")
For j = LBound(v) To UBound(v)
.Columns(j + 1).NumberFormat = v(j)
Next
.Value = AR
End With
Erase AR
Case 2
For j = 0 To objCol.Count - 1
AR(j + 1, 3) = AR(j + 1, 4) '指數漲跌
AR(j + 1, 4) = Round(AR(j + 1, 3) / AR(j + 1, 2), 4) '漲跌幅(%)
Next
With .Range(PARAM(i, 3)).Resize(UBound(AR, 1), UBound(AR, 2))
'設定儲存格格式
v = Split("@;#,##0.00;#,##0.00;0.00%", ";")
For j = LBound(v) To UBound(v)
.Columns(j + 1).NumberFormat = v(j)
Next
.Value = AR
End With
Erase AR
Case Else
End Select
'標註設定儲存格位址顏色
With .Range(PARAM(i, 4)).Interior
.ColorIndex = 35
.Pattern = xlSolid
End With
End With
Next
Finally:
Set objCol = Nothing
Exit Sub
Catch:
If "" <> ErrDescription Then: MsgBox ErrDescription, vbCritical
Err.Clear
Resume Finally
End Sub

複製代碼

作者: jackyq 時間: 2015-7-26 22:49

回復 15# azrael19

大大好
搞得怎麼複雜
動用了大量的 Regular Expression
很累吧

作者: lcctno 時間: 2015-7-26 22:54

回復 15# azrael19

老人家早睡明早又要早起外出運動接著又要盯盤做我參與的股(T50反1) 之成交及統計並輸入而得到分析故等我有空時(星期假日) 再做近一步的 "Try Run" 還請見諒我相信您的能力(事實上證明您是高手行家一出手便知有沒有) 只是我個人的因素無法即時驗證還請見諒希望來日能有機會回報您的幫助 (希望能在股市上幫上忙) 真的很感謝您

作者: azrael19 時間: 2015-7-26 23:21

回復 azrael19

大大好
搞得怎麼複雜
動用了大量的 Regular Expression
很累吧
jackyq 發表於 2015-7-26 22:49

Regular Expression我自己也覺得我寫的又臭又長讓您見笑了，其實網路上有現成的JSON Parser類別可以拿來用，只是lcctno前輩希望程式只能有一個巨集，所以才用這種方式來處理

JSON Parser
https://code.google.com/p/vba-json/

作者: jackyq 時間: 2015-7-26 23:31

回復 18# azrael19

大大莫怪, 沒笑之意
個人習慣是容易維護修改為第一
不想日後修改到挫賽

作者: GBKEE 時間: 2015-7-27 06:09

回復 8# no3-taco
回復 9# azrael19
請問兩位的ie版本,
no3-taco 提供的, MsgBox E.all.Length是多少,

Loop Until E.all.Length >= IIf(i = 0, 431, 150)

複製代碼

這程式碼為何在ie8 沒問題, lcctno 的ie 無法執行.
兩位的IE 也會有這樣的問題嗎?

作者: no3-taco 時間: 2015-7-27 07:34

回復 20# GBKEE

我的是win7 , IE 10 , office2010 需要改成這樣
E.all.Length >= IIf(i = 0, 415, 135)

用(azrael19大大)修改的這一句也不錯
Loop Until 0 < InStr(1, E.outerHTML, IIf(i = 0, "滬深反", "台灣加權股價指數")) '改用相關字串確認是否有資料

作者: GBKEE 時間: 2015-7-27 08:12

本帖最後由 GBKEE 於 2015-7-27 08:15 編輯

回復 21# no3-taco
謝謝你的答覆.
由於我的軟體(xp,2003)一直沒升級,所以在回覆上有些落差.(很抱歉)
再請教第10帖的程式碼,為何非2003版,非ie8 上執行有語法的錯誤.
可否幫忙修正一下.

Loop Until InStr(1, E.outerHTML, IIf(i = 0, "滬深反", "台灣加權股價指數"))

複製代碼

條件公式傳回的數值 0=False, 不等於0都為True

作者: lcctno 時間: 2015-7-27 08:18

回復 15# azrael19

執行結果只出現 "型態不符合" 之訊息

[attach]21503[/attach]

我看您真的很用心幫我解決問題不論結果如何我還是很感謝您的努力謝謝您

作者: azrael19 時間: 2015-7-27 08:30

回復 20# GBKEE
我的是win7 , IE 11 , office2013
跟no3-taco 一樣需要改成 E.all.Length >= IIf(i = 0, 415, 135)

回復 21# no3-taco
後來我改成 Loop Until InStr(1, E.outerHTML, IIf(i = 0, "00638R", "電子類加權股價指數"))比較沒問題

回復 19# jackyq
多謝jackyq大提點，我學習程式的經驗大部分都是網路上Google抓來貼上修改，真正自己寫的不多，確實從沒認真考慮到該如何寫才能讓後續的維護工作更輕鬆，關於這方面的經驗前輩是否可以推薦相關的書籍或網站，還是如果我要用Google搜尋這方面的資料該用什麼樣的關鍵字，謝謝!

關於lcctno大哥所提的問題一開始因為從網頁的原始碼看不到資料，我才想去將JSON資料內容重組來貼，根據jackyq大您的建議我想還是應該以 GBKEE 版主一開始所教用IE來抓取的方式最容易維護，後來我有找到動態產生的網頁原始碼才發現我做了好多白工，只要在貼上工作表前將網頁相關字串內容修改重組就可以讓負號正常顯示出來，下面的程式是用 GBKEE 版主原始碼來做修改，如果有更簡單的方式還希望您們能多指導一下，謝謝!

Option Explicit
Sub Ex()
Dim E As Object, AR(), i As Integer, o As Object, k As Integer
AR = Array("http://www.yuantaetfs.com/#/RtNav/Index", "http://www.yuantaetfs.com/#/Home/Index")
'Ar = Array(網址:即時淨值,網址:國內指數) 網址置入陣列
ActiveSheet.UsedRange.Clear
For i = 0 To 1
With CreateObject("InternetExplorer.Application")
.Visible = True
.Navigate AR(i)
Do While .Busy Or .readyState <> 4: DoEvents: Loop
If i = 0 Then '國內指數:不需按下同意鍵
Do
Set E = .Document.getElementByid("Agree")
Loop Until Not E Is Nothing
E.Click
End If
Do
Do
Set E = .Document.getElementsByTagName("TABLE")(21 + i)
'即時淨值第21個 "TABLE" ,'國內指數第22個 "TABLE"
Loop Until Not E Is Nothing
'Loop Until E.all.Length >= IIf(i = 0, 431, 150) '
Loop Until InStr(1, E.outerHTML, IIf(i = 0, "00638R", "電子類加權股價指數")) '改用相關字串確認是否有資料
'刪除▲ ▼ 符號並加上數字負號顯示
If 0 = i Then
For Each o In E.getElementsByClassName("ng-binding upcolor")
If InStr(1, o.innerText, "▲ ▼") Then
o.innerHTML = Mid(o.innerText, 5)
End If
Next
For Each o In E.getElementsByClassName("ng-binding downcolor")
If InStr(1, o.innerText, "▲ ▼") Then
o.innerHTML = "-" & Mid(o.innerText, 5)
Else
o.innerHTML = "-" & o.innerText
End If
Next
Else
For Each o In E.getElementsByClassName("ChangesText2 downcolor")
k = InStr(1, o.innerText, "(")
If 0 < k Then
o.innerHTML = "-" & Mid(o.innerText, 1, k - 1) & "(-" & Mid(o.innerText, k + 1)
End If
Next
End If
.Document.body.innerHTML = Replace(E.outerHTML, "<span class=""ng-hide"" ng-show=""o.price == 0"">0</span>", "") ' 去除 [折溢價] 數字後面多餘的0
'.Document.body.innerHTML = E.outerHTML
'Stop
.ExecWB 17, 2 ' Select All
.ExecWB 12, 2 ' Copy selection
With ActiveSheet
.Range("A" & IIf(i = 0, 1, 27)).Select
.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False, NoHTMLFormatting:=True
With .Range(IIf(i = 0, "D16:D17", "C27:C28")).Interior
.ColorIndex = 35
.Pattern = xlSolid
End With
End With
.Quit '關閉網頁
End With
Next
End Sub

複製代碼

作者: jackyq 時間: 2015-7-27 08:38

回復 24# azrael19

大大果然聰明
一點就懂
從html下手就可以了

作者: lcctno 時間: 2015-7-27 08:57

回復 24# azrael19
果然是高手已經OK了謝謝您了
[attach]21504[/attach]

作者: lcctno 時間: 2015-7-27 09:23

回復 10# GBKEE

合3 內之按鈕是您的VBA語法但有錯誤現將該檔案上傳感謝您的用心
另外告知於您我是使用WIN7 61位元 Office2003 IE11

[attach]21506[/attach]

作者: GBKEE 時間: 2015-7-27 09:51

回復 27# lcctno
no3-taco ,azrael19 提供
win7, IE 10 , office2010
win7 , IE 11 , office2013
需要改成這樣

E.all.Length >= IIf(i = 0, 415, 135)

複製代碼

找出語法錯誤,第2個Stop 註解符號沒標好, 你提供的圖示剛好擋住 .
請修改後試試看.

Stop '之後按下F5

複製代碼

azrael19 提供的語法
E.getElementsByClassName("ng-binding upcolor")
ie8不支援.

作者: no3-taco 時間: 2015-7-27 09:59

回復 22# GBKEE

其實我也不是很清楚，能在指點問題的癥結點在哪嗎

我抓到的數量就這麼多Loop Until E.all.Length >= IIf(i = 0, 415, 135)，都比版大的少所以會卡住。(判斷式我寫不出完整的)

下面這兩句我執行都可以，有資料都會抓的到(沒有資料我就不知道了)，不知道版大指的是什麼(我的判斷能力有限，沒有很深入了解)
Loop Until InStr(1, E.outerHTML, IIf(i = 0, "滬深反", "台灣加權股價指數"))
Loop Until 0 < InStr(1, E.outerHTML, IIf(i = 0, "滬深反", "台灣加權股價指數"))

作者: GBKEE 時間: 2015-7-27 10:11

回復 29# no3-taco
條件是傳回的值 True 執行, False 不執行

Option Explicit
Sub Ex()
Dim AR(), E As Variant
AR = Array(1, 5, 0, -1, -2)
For Each E In AR
'MsgBox E & " = " & IIf(E, True, False)
If E Then MsgBox E
Next
End Sub

複製代碼

作者: lcctno 時間: 2015-7-27 10:15

回復 28# GBKEE

不知道我有沒有改錯我VBA真的很不懂很難知道(大部分跟本不知道)您所說的還請見諒
[attach]21507[/attach]

修正後的檔案
[attach]21508[/attach]

作者: GBKEE 時間: 2015-7-27 10:28

回復 31# lcctno

[attach]21509[/attach]

你vba 的工作表物件名稱與程式碼的程序名稱相同的衝突.須修改
合1(合1)

作者: lcctno 時間: 2015-7-27 10:38

回復 32# GBKEE

即時淨值合1 合2 均能正常運作
您的內容是使用在合3 請TRY合3內之按鈕5 SUB語法與其他皆相同方式命名唯獨合3 無法正常???

作者: lcctno 時間: 2015-7-27 10:46

回復 32# GBKEE
已改合3
[attach]21510[/attach]

改後出現
[attach]21511[/attach]

作者: no3-taco 時間: 2015-7-27 10:48

回復 28# GBKEE

我還是不清楚版大指的是哪一句有問題
但是
E.all.Length >= IIf(i = 0, 415, 135) ，這個值你的版本還沒把數量抓完就會執行下一行了

作者: GBKEE 時間: 2015-7-27 10:49

回復 33# lcctno
你再試一次, 即時淨值合1 合2 能正常運作?
2003修改Sub 合3 的名稱 ,如 Sub test 就可以了,再試試看
也可請 no3-taco ,azrael19 用2010,2013 試試看

作者: GBKEE 時間: 2015-7-27 10:53

回復 35# no3-taco
0< 可省略掉

Loop Until InStr(1, E.outerHTML, IIf(i = 0, "滬深反", "台灣加權股價指數"))
Loop Until 0 < InStr(1, E.outerHTML, IIf(i = 0, "滬深反", "台灣加權股價指數"))

複製代碼

作者: GBKEE 時間: 2015-7-27 10:59

回復 34# lcctno

[attach]21512[/attach]

你沒改又多了一個要接收的參數.
就Sub test() 試試看

作者: azrael19 時間: 2015-7-27 11:15

回復 lcctno
你再試一次, 即時淨值合1 合2 能正常運作?
2003修改Sub 合3 的名稱 ,如 Sub test 就可以了 ...
GBKEE 發表於 2015-7-27 10:49

報告GBKEE版主我用31#檔案測試三個都可以抓到資料，下圖是合3訊息資料
[attach]21515[/attach]

作者: lcctno 時間: 2015-7-27 11:23

回復 36# GBKEE

由於受限於"本站規定會員每小時最多只能發表 3 個帖子。" 故晚回覆

合1 合2 均能正常動作
不信您可將按鈕5指定句集為合1或合2

我沒看到您所謂的 "你沒改又多了一個要接收的參數"
[attach]21516[/attach]

作者: GBKEE 時間: 2015-7-27 11:40

回復 40# lcctno

合1 合2 均能正常動作
不信您可將按鈕5指定句集為合1或合2

是可以但無法在VBA視窗中按F5執行.
SUB 合3(合3) ,括弧內就是要接收的參數

作者: lcctno 時間: 2015-7-27 11:58

回復 41# GBKEE
我之前是用同樣的語法 Sub 合3() 也無法操作出現400(如圖) 但您說要改成 Sub 合3(合3) ??? 奇怪語法一樣是使用Sub 合2() 可執行但Sub 合3() 就出現400???

[attach]21517[/attach]

作者: no3-taco 時間: 2015-7-27 12:15

回復 35# no3-taco

我本來以為會有順序的抓取，試了幾次好像都從40跳到415

javascript:;

作者: GBKEE 時間: 2015-7-27 12:43

回復 42# lcctno
Sub 合3() 的名稱改成 Sub test() ,再試試看
回復 43# no3-taco
我是想請你將第10貼的原本程式碼,在IE10的下執行看看Length最終是多少

Loop Until E.all.Length >= IIf(i = 0, 431, 150)

複製代碼

作者: no3-taco 時間: 2015-7-27 12:54

回復 44# GBKEE

win7(64bit) ,ie10

415和135

javascript:;

作者: lcctno 時間: 2015-7-27 13:07

回復 24# azrael19

我實在是真的不太好意思再麻煩您將下圖之整排例如1.27(0.10%) 之所以0.10%) 拿掉由於我真的不懂故還是厚著臉皮麻煩您有空時幫個大忙謝謝您的辛勞

[attach]21522[/attach]

作者: lcctno 時間: 2015-7-27 13:14

回復 44# GBKEE
Sub 合3() 的名稱改成 Sub test() 這個我試過
會變成找不到巨集如圖
[attach]21523[/attach]

作者: GBKEE 時間: 2015-7-27 13:28

本帖最後由 GBKEE 於 2015-7-27 13:34 編輯

回復 47# lcctno

你有說: 不信您可將按鈕5指定巨集為合1或合2

按鈕5要重新指定巨集

回復 45# no3-taco
謝謝你

作者: no3-taco 時間: 2015-7-27 13:30

本帖最後由 no3-taco 於 2015-7-27 13:32 編輯

回復 47# lcctno

1.你按鈕要案右鍵，重新指定巨集，
2.不然就是點ㄧ下那個程式碼裡面任意位置再案f5

作者: azrael19 時間: 2015-7-27 13:41

回復 46# lcctno

是這樣嗎

Option Explicit
Sub Ex()
Dim E As Object, AR(), i As Integer, o As Object, k As Integer
AR = Array("http://www.yuantaetfs.com/#/RtNav/Index", "http://www.yuantaetfs.com/#/Home/Index")
'Ar = Array(網址:即時淨值,網址:國內指數) 網址置入陣列
ActiveSheet.UsedRange.Clear
For i = 0 To 1
With CreateObject("InternetExplorer.Application")
.Visible = True
.Navigate AR(i)
Do While .Busy Or .readyState <> 4: DoEvents: Loop
If i = 0 Then '國內指數:不需按下同意鍵
Do
Set E = .Document.getElementByid("Agree")
Loop Until Not E Is Nothing
E.Click
End If
Do
Do
Set E = .Document.getElementsByTagName("TABLE")(21 + i)
'即時淨值第21個 "TABLE" ,'國內指數第22個 "TABLE"
Loop Until Not E Is Nothing
'Loop Until E.all.Length >= IIf(i = 0, 431, 150) '
Loop Until InStr(1, E.outerHTML, IIf(i = 0, "00638R", "電子類加權股價指數")) '改用相關字串確認是否有資料
'刪除▲ ▼ 符號並加上數字負號顯示
If 0 = i Then
For Each o In E.getElementsByClassName("ng-binding upcolor")
If InStr(1, o.innerText, "▲ ▼") Then
o.innerHTML = Mid(o.innerText, 5)
End If
Next
For Each o In E.getElementsByClassName("ng-binding downcolor")
If InStr(1, o.innerText, "▲ ▼") Then
o.innerHTML = "-" & Mid(o.innerText, 5)
Else
o.innerHTML = "-" & o.innerText
End If
Next
Else
'將指數漲跌及漲跌幅%字串分開並加上負號顯示
For Each o In E.getElementsByClassName("ChangesText2 upcolor")
k = InStr(1, o.innerText, "(")
If 0 < k Then
o.outerHTML = "<td>" & Mid(o.innerText, 1, k - 1) & "</td><td>" & Replace(Mid(o.innerText, k + 1), ")", "</td>")
End If
Next
For Each o In E.getElementsByClassName("ChangesText2 downcolor")
k = InStr(1, o.innerText, "(")
If 0 < k Then
o.outerHTML = "<td>-" & Mid(o.innerText, 1, k - 1) & "</td><td>-" & Replace(Mid(o.innerText, k + 1), ")", "</td>")
End If
Next
End If
.Document.body.innerHTML = Replace(E.outerHTML, "<span class=""ng-hide"" ng-show=""o.price == 0"">0</span>", "") ' 去除 [折溢價] 數字後面多餘的0
'.Document.body.innerHTML = E.outerHTML
'Stop
.ExecWB 17, 2 ' Select All
.ExecWB 12, 2 ' Copy selection
With ActiveSheet
.Range("A" & IIf(i = 0, 1, 27)).Select
.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False, NoHTMLFormatting:=True
With .Range(IIf(i = 0, "D16:D17", "C27:C28")).Interior
.ColorIndex = 35
.Pattern = xlSolid
End With
End With
.Quit '關閉網頁
End With
Next
End Sub

複製代碼

作者: lcctno 時間: 2015-7-27 13:54

回復 50# azrael19

真的感謝您已經成功了
[attach]21524[/attach]

作者: lcctno 時間: 2015-7-27 14:08

回復 50# azrael19
可否幫我於"成功了"那圖加上"昨收指數" 之數據結果謝謝若很麻煩我可以用其他方式得到那結果的 "=C27+D27"

[attach]21528[/attach]

作者: lcctno 時間: 2015-7-27 14:59

回復 49# no3-taco
以下內容可能有誤因為還是出現訊息 "400"
Sub test()
Dim E As Object, AR(), i As Integer
AR = Array("http://www.yuantaetfs.com/#/RtNav/Index", "http://www.yuantaetfs.com/#/Home/Index")
'Ar = Array(網址:即時淨值,網址:國內指數) 網址置入陣列
ActiveSheet.UsedRange.Clear
For i = 0 To 1
      With CreateObject("InternetExplorer.Application")
         .Visible = True
         .Navigate AR(i)
         Do While .Busy Or .readyState <> 4: DoEvents: Loop
         If i = 0 Then  '國內指數:不需按下同意鍵
            Do
                  Set E = .Document.getElementByid("Agree")
            Loop Until Not E Is Nothing
            E.Click
         End If
         .Visible = False
         Application.VBE.MainWindow.Visible = True
         Application.VBE.Windows("即時運算").Visible = True
         Stop  '之後按下F5
         Do
            Do
                  Set E = .Document.getElementsByTagName("TABLE")(21 + i)
                  '即時淨值第21個 "TABLE" ,'國內指數第22個 "TABLE"
                  Debug.Print i, "e Is Nothing ->", E Is Nothing
            Loop Until Not E Is Nothing
                  Debug.Print i, "e Is Nothing ->", E Is Nothing, "e.all.Length", E.all.Length
         Loop Until E.all.Length >= IIf(i = 0, 415, 135) '
         Stop  '之後按下F5

         Application.VBE.Windows("即時運算").Visible = False
         Application.VBE.MainWindow.Visible = False
         .Document.body.innerHTML = E.outerHTML
         .ExecWB 17, 2    '  Select All
         .ExecWB 12, 2    '  Copy selection
         With ActiveSheet
            .Range("A" & IIf(i = 0, 1, 27)).Select
            .PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False, NoHTMLFormatting:=True
            With .Range(IIf(i = 0, "D16:D17", "C27:C28")).Interior
                  .ColorIndex = 35
                  .Pattern = xlSolid
            End With
         End With
         .Quit       '關閉網頁
      End With
Next
End Sub

[attach]21529[/attach]

作者: azrael19 時間: 2015-7-27 15:32

回復 52# lcctno

其實不會麻煩,不過我會先建議您將程式中ActiveSheet.UsedRange.Clear這一行註解或刪掉,這樣你在其它儲存格所加的任何公式或文字就不會被清除,這樣子會比用程式寫更具有彈性...

ActiveSheet.UsedRange.Clear

複製代碼

改成

'ActiveSheet.UsedRange.Clear

複製代碼

作者: lcctno 時間: 2015-7-27 16:35

回復 54# azrael19
已將那行加上 " ' " (註解)
感謝您了
不知您有沒有參與股票我有做大盤及金融類股的指數做分析 "大盤+金融累計發生率" 若有興趣我設法將統計結果給您希望有機會能對您有所回饋

部分之一的分析截圖
[attach]21536[/attach]

作者: no3-taco 時間: 2015-7-27 18:11

回復 53# lcctno

你貼的我有執行，沒有問題，也看不出哪裡有問題
我覺得可能是其他問題
建議你重開一個excel檔案,再測試看看
再不行我也沒辦法

作者: lcctno 時間: 2015-7-27 18:30

回復 56# no3-taco
那怪了是"合3"裏的"按鈕5" 能正常執行???
因為其餘 "即時淨值" "合1" "合2" 在我這裡本來就能正常運作只有"合3"裏的"按鈕5" 執行時會出現訊息 "400"
您確定您是執行"合3"裏的"按鈕5"媽?
謝謝您的用心謝謝了

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