返回列表 上一主題 發帖

[發問] 請問能否將2個VBA巨集合併成1個VBA巨集

azrael19

帖子
23 
主題
0 
精華
0 
積分
73 
點名
149  
作業系統
XP 
軟體版本
Office 2003 
閱讀權限
20 
註冊時間
2012-4-21 
最後登錄
2025-6-15 

2024年全勤獎章2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章
1# 跳轉到 »
發表於 2015-7-26 09:41 | 顯示全部帖子
回復  GBKEE

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

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


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

TOP

azrael19

帖子
23 
主題
0 
精華
0 
積分
73 
點名
149  
作業系統
XP 
軟體版本
Office 2003 
閱讀權限
20 
註冊時間
2012-4-21 
最後登錄
2025-6-15 

2024年全勤獎章2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章
2#
發表於 2015-7-26 21:53 | 顯示全部帖子
回復  azrael19

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


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


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

  4. Sub Ex()
  5.     Dim HEAD As Variant, PARAM As Variant, PA As Variant, AR As Variant, v As Variant
  6.     Dim i As Integer, j As Integer, k As Integer
  7.     Dim s As String, ErrDescription As String
  8.     Dim objCol As Object
  9.    
  10.     '參數 : 網址,表頭放置位址,資料放置儲存格位址,標註顏色儲存格位址
  11.     PARAM = [{"http://www.yuantaetfs.com/api/RtNav","B1","B5","D16:D17"; "http://www.yuantaetfs.com/Home/IndexPrice","","B27","C27:C28"}]
  12.    
  13.     '資料表頭陣列字串
  14.     HEAD = Array("{""資料時間"","""","""","""","""","""","""","""","""","""","""","""","""","""","""";" & _
  15.                  """基本資料"","""",""淨值"","""","""","""",""市價"","""","""","""",""折溢價"","""",""初級市場"","""",""基金"";" & _
  16.                  """股票"",""基金"",""昨收"",""預估"",""漲跌"",""漲跌幅"",""昨收"",""最新"",""漲跌"",""漲跌幅"",""折溢價"",""幅度"",""可否"",""可否"",""營業日"";" & _
  17.                  """代碼"",""名稱"",""淨值"",""淨值"","""","""",""市價"",""市價"","""","""","""","""",""申購"",""贖回"",""""}", "")
  18.                  
  19.     'Regular Expression
  20.     PA = Array("{""fundId"":""[\d]+"",""etfId"":""(.+?)"",""name"":""(.+?)"",""ename"":""[^""]*"",""yestNav"":(.+?),""nav"":(.+?),""navFluct"":(.+?),""yestPrice"":(.+?),""price"":(.+?),""priceFluct"":(.+?),""yestIndex"":(.+?),""index"":(.+?),""indexFluct"":(.+?),""updateTime"":""(.+?)"",""AllowMark"":""(.+?)"",""RedemMark"":""(.+?)"",""BussMark"":""(.+?)"",[^}]+}", _
  21.                "{""fund_id"":null,""IndexCode"":""[^""]*"",""IndexName"":""([^""]+)"",""IndexEName"":""[^""]*"",""crncy"":""[^""]*"",""area"":""D"",""DayDate"":""[^""]*"",""Close"":(.+?),""yestClose"":(.+?),""Diff"":(.+?)}")

  23.     ActiveSheet.UsedRange.ClearContents
  24.    
  25.     For i = LBound(PARAM) To UBound(PARAM)
  26.    
  27.         '抓取JSON資料
  28.         With CreateObject("WinHttp.WinHttpRequest.5.1")
  29.             .Open "GET", PARAM(i, 1), False
  30.             .send
  31.             If 200# <> .Status Then
  32.                 ErrDescription = "網頁讀取失敗!"
  33.                 GoTo Catch
  34.             End If
  35.             s = .responseText
  36.         End With
  37.         
  38.         With ActiveSheet
  39.             If "" <> PARAM(i, 2) Then
  40.                 '放置表頭資料
  41.                 AR = Application.Evaluate(HEAD(i))
  42.                 .Range(PARAM(i, 2)).Resize(UBound(AR, 1), UBound(AR, 2)).Value = AR
  43.                 Erase AR
  44.             End If
  45.             If "" <> PA(i) Then
  46.                 '解析JSON字串中所需資料
  47.                 With CreateObject("VBScript.RegExp")
  48.                     .Global = True
  49.                     .Pattern = PA(i)
  50.                     If False = .test(s) Then: GoTo Catch
  51.                     Set objCol = Nothing
  52.                     Set objCol = .Execute(s)
  53.                 End With
  54.                 If 0 = objCol.Count Then
  55.                     ErrDescription = "資料格式解析錯誤!"
  56.                     GoTo Catch
  57.                 End If
  58.                 ReDim AR(1 To objCol.Count, 1 To objCol(1).SubMatches.Count) As Variant
  59.                 For j = 0 To objCol.Count - 1
  60.                     For k = 0 To objCol(0).SubMatches.Count - 1
  61.                         AR(j + 1, k + 1) = objCol(j).SubMatches(k)
  62.                     Next k
  63.                 Next
  64.             End If
  65.             
  66.             Select Case i
  67.                 Case 1
  68.                     '重新排列及修正資料以符合網頁表格所呈現樣貌
  69.                     For j = 0 To objCol.Count - 1
  70.                         AR(j + 1, 9) = AR(j + 1, 8)                            '漲跌
  71.                         AR(j + 1, 8) = AR(j + 1, 7)                            '最新市價
  72.                         AR(j + 1, 7) = AR(j + 1, 6)                            '昨收市價
  73.                         AR(j + 1, 6) = Round(AR(j + 1, 5) / AR(j + 1, 3), 4)   '漲跌幅
  74.                         AR(j + 1, 10) = Round(AR(j + 1, 9) / AR(j + 1, 7), 4)  '漲跌幅
  75.                         AR(j + 1, 11) = AR(j + 1, 8) - AR(j + 1, 4)            '折溢價
  76.                         AR(j + 1, 12) = Round(AR(j + 1, 11) / AR(j + 1, 4), 4) '幅度
  77.                     Next j
  78.                     .Range("B1").Value = "資料時間:" & Trim(objCol(0).SubMatches(11))
  79.                     With .Range(PARAM(i, 3)).Resize(UBound(AR, 1), UBound(AR, 2))
  80.                         '設定儲存格格式
  81.                         v = Split("@,@,0.00,0.00,0.00,0.00%,0.00,0.00,0.00,0.00%,0.00,0.00%", ",")
  82.                         For j = LBound(v) To UBound(v)
  83.                             .Columns(j + 1).NumberFormat = v(j)
  84.                         Next
  85.                         .Value = AR
  86.                     End With
  87.                     Erase AR
  88.                 Case 2
  89.                     For j = 0 To objCol.Count - 1
  90.                         AR(j + 1, 3) = AR(j + 1, 4)                            '指數漲跌
  91.                         AR(j + 1, 4) = Round(AR(j + 1, 3) / AR(j + 1, 2), 4)   '漲跌幅(%)
  92.                     Next
  93.                     With .Range(PARAM(i, 3)).Resize(UBound(AR, 1), UBound(AR, 2))
  94.                         '設定儲存格格式
  95.                         v = Split("@;#,##0.00;#,##0.00;0.00%", ";")
  96.                         For j = LBound(v) To UBound(v)
  97.                             .Columns(j + 1).NumberFormat = v(j)
  98.                         Next
  99.                         .Value = AR
  100.                     End With
  101.                     Erase AR
  102.                 Case Else
  103.             End Select
  104.         
  105.             '標註設定儲存格位址顏色
  106.             With .Range(PARAM(i, 4)).Interior
  107.                 .ColorIndex = 35
  108.                 .Pattern = xlSolid
  109.             End With
  110.         End With
  111.         
  112.     Next
  113.    
  114. Finally:
  115.     Set objCol = Nothing

  117.     Exit Sub
  118. Catch:

  120.     If "" <> ErrDescription Then: MsgBox ErrDescription, vbCritical
  121.     Err.Clear
  122.     Resume Finally

  124. End Sub
複製代碼

TOP

azrael19

帖子
23 
主題
0 
精華
0 
積分
73 
點名
149  
作業系統
XP 
軟體版本
Office 2003 
閱讀權限
20 
註冊時間
2012-4-21 
最後登錄
2025-6-15 

2024年全勤獎章2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章
3#
發表於 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/

TOP

azrael19

帖子
23 
主題
0 
精華
0 
積分
73 
點名
149  
作業系統
XP 
軟體版本
Office 2003 
閱讀權限
20 
註冊時間
2012-4-21 
最後登錄
2025-6-15 

2024年全勤獎章2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章
4#
發表於 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 版主原始碼來做修改，如果有更簡單的方式還希望您們能多指導一下，謝謝!
  1. Option Explicit
  2. Sub Ex()
  3.     Dim E As Object, AR(), i As Integer, o As Object, k As Integer
  4.     AR = Array("http://www.yuantaetfs.com/#/RtNav/Index", "http://www.yuantaetfs.com/#/Home/Index")
  5.     'Ar = Array(網址:即時淨值,網址:國內指數) 網址置入陣列
  6.     ActiveSheet.UsedRange.Clear
  7.     For i = 0 To 1
  8.         With CreateObject("InternetExplorer.Application")
  9.             .Visible = True
  10.             .Navigate AR(i)
  11.             Do While .Busy Or .readyState <> 4: DoEvents: Loop
  12.             If i = 0 Then  '國內指數:不需按下同意鍵
  13.                 Do
  14.                     Set E = .Document.getElementByid("Agree")
  15.                 Loop Until Not E Is Nothing
  16.                 E.Click
  17.             End If
  18.             Do
  19.                 Do
  20.                     Set E = .Document.getElementsByTagName("TABLE")(21 + i)
  21.                     '即時淨值 第21個 "TABLE" ,'國內指數 第22個 "TABLE"
  22.                 Loop Until Not E Is Nothing
  23.             'Loop Until E.all.Length >= IIf(i = 0, 431, 150) '
  24.             Loop Until InStr(1, E.outerHTML, IIf(i = 0, "00638R", "電子類加權股價指數"))  '改用相關字串確認是否有資料
  25.             
  26.             '刪除▲ ▼ 符號並加上數字負號顯示
  27.             If 0 = i Then
  28.                 For Each o In E.getElementsByClassName("ng-binding upcolor")
  29.                     If InStr(1, o.innerText, "▲ ▼") Then
  30.                         o.innerHTML = Mid(o.innerText, 5)
  31.                     End If
  32.                 Next
  33.                 For Each o In E.getElementsByClassName("ng-binding downcolor")
  34.                     If InStr(1, o.innerText, "▲ ▼") Then
  35.                         o.innerHTML = "-" & Mid(o.innerText, 5)
  36.                     Else
  37.                         o.innerHTML = "-" & o.innerText
  38.                     End If
  39.                 Next
  40.             Else
  41.                 For Each o In E.getElementsByClassName("ChangesText2 downcolor")
  42.                     k = InStr(1, o.innerText, "(")
  43.                     If 0 < k Then
  44.                         o.innerHTML = "-" & Mid(o.innerText, 1, k - 1) & "(-" & Mid(o.innerText, k + 1)
  45.                     End If
  46.                 Next
  47.             End If
  48.             .Document.body.innerHTML = Replace(E.outerHTML, "<span class=""ng-hide"" ng-show=""o.price == 0"">0</span>", "") ' 去除 [折溢價] 數字後面多餘的0
  49.             '.Document.body.innerHTML = E.outerHTML
  50.             'Stop
  51.             .ExecWB 17, 2       '  Select All
  52.             .ExecWB 12, 2       '  Copy selection
  53.             With ActiveSheet
  54.                 .Range("A" & IIf(i = 0, 1, 27)).Select
  55.                 .PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False, NoHTMLFormatting:=True
  56.                 With .Range(IIf(i = 0, "D16:D17", "C27:C28")).Interior
  57.                     .ColorIndex = 35
  58.                     .Pattern = xlSolid
  59.                 End With
  60.             End With
  61.             .Quit        '關閉網頁
  62.         End With
  63.     Next
  64. End Sub
複製代碼

TOP

azrael19

帖子
23 
主題
0 
精華
0 
積分
73 
點名
149  
作業系統
XP 
軟體版本
Office 2003 
閱讀權限
20 
註冊時間
2012-4-21 
最後登錄
2025-6-15 

2024年全勤獎章2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章
5#
發表於 2015-7-27 11:15 | 顯示全部帖子
回復  lcctno
你再試一次, 即時淨值 合1 合2 能正常運作?
2003修改Sub 合3 的名稱 ,如 Sub test 就可以了 ...
GBKEE 發表於 2015-7-27 10:49


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

TOP

azrael19

帖子
23 
主題
0 
精華
0 
積分
73 
點名
149  
作業系統
XP 
軟體版本
Office 2003 
閱讀權限
20 
註冊時間
2012-4-21 
最後登錄
2025-6-15 

2024年全勤獎章2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章
6#
發表於 2015-7-27 13:41 | 顯示全部帖子
回復 46# lcctno

是這樣嗎
  1. Option Explicit
  2. Sub Ex()
  3.     Dim E As Object, AR(), i As Integer, o As Object, k As Integer
  4.     AR = Array("http://www.yuantaetfs.com/#/RtNav/Index", "http://www.yuantaetfs.com/#/Home/Index")
  5.     'Ar = Array(網址:即時淨值,網址:國內指數) 網址置入陣列
  6.     ActiveSheet.UsedRange.Clear
  7.     For i = 0 To 1
  8.         With CreateObject("InternetExplorer.Application")
  9.             .Visible = True
  10.             .Navigate AR(i)
  11.             Do While .Busy Or .readyState <> 4: DoEvents: Loop
  12.             If i = 0 Then  '國內指數:不需按下同意鍵
  13.                 Do
  14.                     Set E = .Document.getElementByid("Agree")
  15.                 Loop Until Not E Is Nothing
  16.                 E.Click
  17.             End If
  18.             Do
  19.                 Do
  20.                     Set E = .Document.getElementsByTagName("TABLE")(21 + i)
  21.                     '即時淨值 第21個 "TABLE" ,'國內指數 第22個 "TABLE"
  22.                 Loop Until Not E Is Nothing
  23.             'Loop Until E.all.Length >= IIf(i = 0, 431, 150) '
  24.             Loop Until InStr(1, E.outerHTML, IIf(i = 0, "00638R", "電子類加權股價指數"))  '改用相關字串確認是否有資料
  25.             
  26.             '刪除▲ ▼ 符號並加上數字負號顯示
  27.             If 0 = i Then
  28.                 For Each o In E.getElementsByClassName("ng-binding upcolor")
  29.                     If InStr(1, o.innerText, "▲ ▼") Then
  30.                         o.innerHTML = Mid(o.innerText, 5)
  31.                     End If
  32.                 Next
  33.                 For Each o In E.getElementsByClassName("ng-binding downcolor")
  34.                     If InStr(1, o.innerText, "▲ ▼") Then
  35.                         o.innerHTML = "-" & Mid(o.innerText, 5)
  36.                     Else
  37.                         o.innerHTML = "-" & o.innerText
  38.                     End If
  39.                 Next
  40.             Else
  41.                 '將指數漲跌及漲跌幅%字串分開並加上負號顯示
  42.                 For Each o In E.getElementsByClassName("ChangesText2 upcolor")
  43.                     k = InStr(1, o.innerText, "(")
  44.                     If 0 < k Then
  45.                         o.outerHTML = "<td>" & Mid(o.innerText, 1, k - 1) & "</td><td>" & Replace(Mid(o.innerText, k + 1), ")", "</td>")
  46.                     End If
  47.                 Next
  48.                 For Each o In E.getElementsByClassName("ChangesText2 downcolor")
  49.                     k = InStr(1, o.innerText, "(")
  50.                     If 0 < k Then
  51.                         o.outerHTML = "<td>-" & Mid(o.innerText, 1, k - 1) & "</td><td>-" & Replace(Mid(o.innerText, k + 1), ")", "</td>")
  52.                     End If
  53.                 Next
  54.             End If
  55.             .Document.body.innerHTML = Replace(E.outerHTML, "<span class=""ng-hide"" ng-show=""o.price == 0"">0</span>", "") ' 去除 [折溢價] 數字後面多餘的0
  56.             '.Document.body.innerHTML = E.outerHTML
  57.             'Stop
  58.             .ExecWB 17, 2       '  Select All
  59.             .ExecWB 12, 2       '  Copy selection
  60.             With ActiveSheet
  61.                 .Range("A" & IIf(i = 0, 1, 27)).Select
  62.                 .PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False, NoHTMLFormatting:=True
  63.                 With .Range(IIf(i = 0, "D16:D17", "C27:C28")).Interior
  64.                     .ColorIndex = 35
  65.                     .Pattern = xlSolid
  66.                 End With
  67.             End With
  68.             .Quit        '關閉網頁
  69.         End With
  70.     Next
  71. End Sub
複製代碼

TOP

azrael19

帖子
23 
主題
0 
精華
0 
積分
73 
點名
149  
作業系統
XP 
軟體版本
Office 2003 
閱讀權限
20 
註冊時間
2012-4-21 
最後登錄
2025-6-15 

2024年全勤獎章2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章
7#
發表於 2015-7-27 15:32 | 顯示全部帖子
回復 52# lcctno

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

TOP

        靜思自在 : 能幹不幹，不如苦幹實幹。
返回列表 上一主題