[發問] 請問能否將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

lcctno

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

no3-taco

回復 53# lcctno

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

lcctno

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

部分之一的分析截圖

下載 (78.11 KB)

2015-7-27 16:34

azrael19

回復 52# lcctno

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

1. ActiveSheet.UsedRange.Clear

複製代碼

改成

1. 'ActiveSheet.UsedRange.Clear

複製代碼

lcctno

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

下載 (224.53 KB)

2015-7-27 14:58

lcctno

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

下載 (236.75 KB)

2015-7-27 14:08

lcctno

回復 50# azrael19

真的感謝您 已經成功了

下載 (245.59 KB)

2015-7-27 13:53

azrael19

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

複製代碼

no3-taco

回復 47# lcctno


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