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

lcctno

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

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

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

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

lcctno

回復 2# Min

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

GBKEE

回復 3# lcctno
試試看

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.             .Document.body.innerHTML = E.outerHTML
    
25.             .ExecWB 17, 2       '  Select All
    
26.             .ExecWB 12, 2       '  Copy selection
    
27.             With ActiveSheet
    
28.                 .Range("A" & IIf(i = 0, 1, 27)).Select
    
29.                 .PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False, NoHTMLFormatting:=True
    
30.                 With .Range(IIf(i = 0, "D16:D17", "C27:C28")).Interior
    
31.                     .ColorIndex = 35
    
32.                     .Pattern = xlSolid
    
33.                 End With
    
34.             End With
    
35.             .Quit        '關閉網頁
    
36.         End With
    
37.     Next
    
38. End Sub

複製代碼

lcctno

回復 4# GBKEE

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

1.會卡住

下載 (276.61 KB)

2015-7-25 23:37

2.錯誤訊息

下載 (184.2 KB)

2015-7-25 23:37

3.偵錯

下載 (70.62 KB)

2015-7-25 23:37

GBKEE

回復 5# lcctno

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

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

複製代碼

修改試試

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

複製代碼

lcctno

回復 6# GBKEE

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

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

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

no3-taco

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

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

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

複製代碼

azrael19

回復  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

複製代碼

GBKEE

回復 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

複製代碼