如何撈兩筆以上股票資料

afu9240

各位高手好
  小妹 vba小嫩嫩,這段程式有什麻方式可修改 讓他不會卡住,求幫忙!!!感謝

1. Sub stock()
   
2.     Dim oXMLHTTP As Object
   
3.     Dim sPageHTML As String
   
4.     Dim sURL As String '前面三項變數必key
   
5.     a = 0
   
6.     Do
   
7.         a = a + 1
   
8.         Select Case a
   
9.             Case 1
   
10.                 sURL = "https://tw.stock.yahoo.com/q/q?s=" & Sheets(3).Cells(36, 6) '連結股票代號
    
11.             Case 2
    
12.                 sURL = "https://tw.stock.yahoo.com/q/q?s=" & Sheets(3).Cells(37, 6)
    
13.             
    
14.             
    
15.             End Select
    
16.             Set oXMLHTTP = CreateObject("MSXML2.ServerXMLHTTP")
    
17.             oXMLHTTP.Open "GET", sURL, False
    
18.             oXMLHTTP.send
    
19.             sPageHTML = oXMLHTTP.responseText
    
20.             
    
21.             Select Case a
    
22.                 Case 1
    
23.                     Sheets(5).Cells(1, 1) = sPageHTML '將網頁資訊貼到這個位置
    
24.                 Case 2
    
25.                     Sheets(5).Cells(1, 2) = sPageHTML
    
26.                
    
27.                
    
28.                     
    
29.             End Select
    
30.             If a = 2 Then
    
31.                  Exit Do
    
32.             End If
    
33.                
    
34.      Loop
    
35.    
    
36.     aaa = Sheets(5).Cells(1, 1) '網址路徑aaa
    
37.    
    
38.     aaalen = Len(aaa)  'len取網頁資訊
    
39.    
    
40.    
    
41.     yy = 0
    
42.     Y = 1
    
43.         For t = 1 To aaalen    '到網頁找特徵資料來擷取我們要的資料
    
44.            
    
45.         If Mid(aaa, t, Len("nowrap")) = "nowrap" Then '特徵nowrap 要去文字檔搜尋網頁特徵
    
46.             
    
47.             
    
48.         cc = 0
    
49.             
    
50.         t = t + Len("nowrap")
    
51.         q1 = ""
    
52.       
    
53. 
    
54.         Do
    
55.             If Mid(aaa, t, 1) = ">" Then 'aaa網路路徑資料,第t個值取第一筆資料
    
56. 
    
57.                 q1 = ""
    
58.                 cc = 1
    
59.                 yy = yy + 1
    
60.                 Y = Y + 1
    
61.                 If yy = 2 Then 'yy為第幾筆資料
    
62.                     t = t + 4 '從特徵資料到你要擷取的資料要加多少
    
63.                 ElseIf yy = 5 Then
    
64.                     t = t + 21
    
65.                 Else
    
66.                     t = t + 1
    
67.                 End If
    
68. 
    
69. 
    
70.           End If
    
71.           If Mid(aaa, t, 1) = "<" Then
    
72.             If yy = 5 Then
    
73.                 Sheets(4).Cells(2, Y) = Left(RTrim(LTrim(q1)), Len(RTrim(LTrim(q1))) - 1) '將該欄資料置中
    
74.                
    
75.             Else
    
76.                 Sheets(4).Cells(2, Y) = RTrim(LTrim(q1))
    
77.          
    
78.             End If
    
79.             q1 = ""
    
80.             cc = 0
    
81.             Exit Do
    
82.         End If
    
83.         If cc = 1 Then
    
84.            q1 = q1 & Mid(aaa, t, 1)
    
85.         End If
    
86. 
    
87.             t = t + 1
    
88.         Loop
    
89.      
    
90.     End If
    
91.      
    
92.      
    
93.      
    
94.         bbb = Sheets(5).Cells(1, 2) '網址路徑aaa
    
95. 
    
96.         bbblen = Len(bbb) 'len取網頁資訊
    
97. 
    
98.         yy = 0
    
99.         Y = 1
    
100.          For i = 1 To bbblen '到網頁找特徵資料來擷取我們要的資料
     
101.         If Mid(bbb, i, Len("nowrap")) = "nowrap" Then '特徵nowrap 要去文字檔搜尋網頁特徵
     
102.         cc = 0
     
103.         i = i + Len("nowrap")
     
104.         q1 = ""
     
105. 
     
106.         Do
     
107.             If Mid(bbb, i, 1) = ">" Then 'aaa網路路徑資料,第t個值取第一筆資料
     
108. 
     
109.                 q1 = ""
     
110.                 cc = 1
     
111.                 yy = yy + 1
     
112.                 Y = Y + 1
     
113.                 If yy = 2 Then 'yy為第幾筆資料
     
114.                     i = i + 4 '從特徵資料到你要擷取的資料要加多少
     
115.                 ElseIf yy = 5 Then
     
116.                     i = i + 21
     
117.                 Else
     
118.                     i = i + 1
     
119.                 End If
     
120. 
     
121. 
     
122.             End If
     
123.             If Mid(bbb, i, 1) = "<" Then
     
124.             If yy = 5 Then
     
125.                 Sheets(4).Cells(3, Y) = Left(RTrim(LTrim(q1)), Len(RTrim(LTrim(q1))) - 1) '將該欄資料置中
     
126. 
     
127.             Else
     
128.                 Sheets(4).Cells(3, Y) = RTrim(LTrim(q1))
     
129. 
     
130. 
     
131. 
     
132. 
     
133. 
     
134.             End If
     
135.             q1 = ""
     
136.             cc = 0
     
137.             Exit Do
     
138.         End If
     
139.         If cc = 1 Then
     
140.             q1 = q1 & Mid(bbb, i, 1)
     
141.         End If
     
142. 
     
143.             i = i + 1
     
144. 
     
145. 
     
146.         Loop
     
147.      End If
     
148.     Next i
     
149.    Next t
     
150.    
     
151. End Sub

複製代碼

Scott090

回復 1# afu9240

請問 這個程式碼 是要撈股票的什麼資料?
是這樣嗎?
    股票
    代號        時間        成交        買進        賣出        漲跌        張數        昨收        開盤        最高        最低        個股資料

afu9240

回復 2# Scott090


    我把檔案寄給你 看一下

afu9240

檔案如附件,我要撈的股票在前sheets,您幫我看下,code會卡住,並須要強迫關閉[ 20171115.zip (36.81 KB)

下載次數: 3

2017-11-15 12:47

Scott090

回復 4# afu9240

請先參考這個範例
    http://forum.twbts.com/viewthrea ... hlight=%AA%D1%B2%BC

afu9240

感謝s大,真的是高手如雲,想請教要看兩檔以上的股票,裡面的code只要再加上網址就好嗎???

Scott090

回復 6# afu9240


    1. 請貼出程式碼作品會比較容易瞭解問題
    2. 不要忘了 在 "回復" 的地方按一下

afu9240

我前面有附上檔案過給您看,一次只能看一檔個股

Scott090

回復 8# afu9240

這是妳要的嗎?
   

下載 (47.3 KB)

2017-11-18 10:28

下載 (74.06 KB)

2017-11-18 10:29

網頁中股票資料20171118.zip (48.44 KB)

下載次數: 26

2017-11-18 10:31