123456
返回列表 上一主題 發帖

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

azrael19

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

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

lcctno

帖子
142 
主題
18 
精華
0 
積分
160 
點名
177  
作業系統
win10 64位元 
軟體版本
office2003 
閱讀權限
20 
性別
男 
來自
臺灣 高雄市 
註冊時間
2015-7-18 
最後登錄
2024-7-3 

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章
17#
發表於 2015-7-26 22:54 | 只看該作者
回復 15# azrael19

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

TOP

jackyq

帖子
319 
主題
6 
精華
0 
積分
309 
點名
0  
作業系統
xp 
軟體版本
2k 
閱讀權限
20 
性別
男 
註冊時間
2015-6-24 
最後登錄
2024-4-27 
16#
發表於 2015-7-26 22:49 | 只看該作者
回復 15# azrael19

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

TOP

azrael19

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

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

lcctno

帖子
142 
主題
18 
精華
0 
積分
160 
點名
177  
作業系統
win10 64位元 
軟體版本
office2003 
閱讀權限
20 
性別
男 
來自
臺灣 高雄市 
註冊時間
2015-7-18 
最後登錄
2024-7-3 

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章
14#
發表於 2015-7-26 12:09 | 只看該作者
回復 8# no3-taco
由於等網站對菜鳥的每小時只能回覆3次的限制 故晚了回覆

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

TOP

lcctno

帖子
142 
主題
18 
精華
0 
積分
160 
點名
177  
作業系統
win10 64位元 
軟體版本
office2003 
閱讀權限
20 
性別
男 
來自
臺灣 高雄市 
註冊時間
2015-7-18 
最後登錄
2024-7-3 

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章
13#
發表於 2015-7-26 11:13 | 只看該作者
回復 9# azrael19

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


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

謝謝您

TOP

lcctno

帖子
142 
主題
18 
精華
0 
積分
160 
點名
177  
作業系統
win10 64位元 
軟體版本
office2003 
閱讀權限
20 
性別
男 
來自
臺灣 高雄市 
註冊時間
2015-7-18 
最後登錄
2024-7-3 

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章
12#
發表於 2015-7-26 10:51 | 只看該作者
回復 10# GBKEE
無法執行(原因:我是菜鳥無能力修改完成)
1 語法錯誤


2.錯誤內容


感謝您熱心的參與 謝謝您

TOP

lcctno

帖子
142 
主題
18 
精華
0 
積分
160 
點名
177  
作業系統
win10 64位元 
軟體版本
office2003 
閱讀權限
20 
性別
男 
來自
臺灣 高雄市 
註冊時間
2015-7-18 
最後登錄
2024-7-3 

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章
11#
發表於 2015-7-26 10:30 | 只看該作者
回復 9# azrael19

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

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
10#
發表於 2015-7-26 10:28 | 只看該作者
本帖最後由 GBKEE 於 2015-7-27 09:53 編輯

回復 7# lcctno

當下只發生自動開啟IE11 停在"5樓的圖1.
此程式執行後會回到VBA編輯視窗,並打開'即時運算"的視窗
請第一個STOP 之後按下F5
如停留在VBA編輯視窗,"即時運算"一直有字串出現,代表程式一直在等後IE的資料,是IE 的問題
**請耐心等候到下 一個 STOP 之後按下F5 **
  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.             .Visible = False
  19.             Application.VBE.MainWindow.Visible = True
  20.             Application.VBE.Windows("即時運算").Visible = True
  21.             Stop  '之後按下F5
  22.             Do
  23.                 Do
  24.                     Set E = .Document.getElementsByTagName("TABLE")(21 + i)
  25.                     '即時淨值 第21個 "TABLE" ,'國內指數 第22個 "TABLE"
  26.                     Debug.Print i, "e Is Nothing ->", E Is Nothing
  27.                 Loop Until Not E Is Nothing
  28.                     Debug.Print i, "e Is Nothing ->", E Is Nothing, "e.all.Length", E.all.Length
  29.             Loop Until E.all.Length >= IIf(i = 0, 431, 150) '
  30.             Stop  '之後按下F5
  31.             
  32.             Application.VBE.Windows("即時運算").Visible = False
  33.             Application.VBE.MainWindow.Visible = False
  34.             .Document.body.innerHTML = E.outerHTML
  35.             .ExecWB 17, 2       '  Select All
  36.             .ExecWB 12, 2       '  Copy selection
  37.             With ActiveSheet
  38.                 .Range("A" & IIf(i = 0, 1, 27)).Select
  39.                 .PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False, NoHTMLFormatting:=True
  40.                 With .Range(IIf(i = 0, "D16:D17", "C27:C28")).Interior
  41.                     .ColorIndex = 35
  42.                     .Pattern = xlSolid
  43.                 End With
  44.             End With
  45.             .Quit        '關閉網頁
  46.         End With
  47.     Next
  48. End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

azrael19

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

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

        靜思自在 : 做該做的事是智慧，做不該做的事是愚癡。
123456
返回列表 上一主題