[發問] Web更新網頁，會跑出 2組出來 (黃色)

7777

請教
Web更新網頁，會跑出 2組出來 (黃色)
1.該 如何解決處理~
2.可以 如何簡化...感謝

VB 慢慢..學習中

下載 (297.09 KB)

2018-9-4 12:40

test-023.rar (21.58 KB)

下載次數: 17

2018-9-4 12:39

7777

回復 4# GBKEE

謝謝 GBKEE 的分享！
程式OK

Set E = oHtmldoc.all.tags("TABLE")( 12))
多了 一個 ")"

感謝

7777

回復 3# iamaraymond

感謝
Raymond Chien 的大力幫忙
程式OK
本人再研究學習中，
超級感謝~~熱心的幫忙。

a5007185

回復 4# GBKEE


謝謝超級板主的分享！
因為有你們熱心的分享，
才能讓我們這些後輩可以開眼界~  : )

GBKEE

回復 1# 7777

1. Option Explicit
   
2. Sub EX_網頁()
   
3.     Dim oXmlhttp As Object, oHtmldoc As Object, E As Object, R As Integer, C As Integer
   
4.     Dim I As Integer, AR(1 To 2)
   
5.     AR(1) = "http://info512.taifex.com.tw/Future/FusaQuote_Norl.aspx"
   
6.     AR(2) = "http://info512.taifex.com.tw/Future/OptQuote_Norl.aspx"
   
7.     Cells.Clear
   
8.     For I = 1 To 2
   
9.         Set oXmlhttp = CreateObject("msxml2.xmlhttp")
   
10.         Set oHtmldoc = CreateObject("htmlfile")
    
11.         With oXmlhttp
    
12.             .Open "Get", AR(I), False
    
13.             .send
    
14.             oHtmldoc.write .responseText
    
15.         End With
    
16.         Set E = oHtmldoc.all.tags("TABLE")( 12))
    
17.         For R = 0 To E.Rows.Length - 1
    
18.             For C = 0 To E.Rows(R).Cells.Length - 1
    
19.                 With IIf(I = 1, [A26], [T26])
    
20.                 .Cells(R + 1, C + 1) = E.Rows(R).Cells(C).innerText
    
21.                 End With
    
22.             Next
    
23.         Next
    
24.         Set oXmlhttp = Nothing
    
25.         Set oHtmldoc = Nothing
    
26.     Next
    
27. End Sub

複製代碼

iamaraymond

回復 1# 7777

1. Sub Future()
   
2. 
   
3. Dim myXML As Object
   
4. Set myXML = CreateObject("Microsoft.XMLHTTP")
   
5. 
   
6. Dim myHTML As Object
   
7. Set myHTML = CreateObject("HTMLFile")
   
8. 
   
9. ReDim myArr(1 To 55, 1 To 15)
   
10. 
    
11. With myXML
    
12.     .Open "GET", "http://info512.taifex.com.tw/Future/FusaQuote_Norl.aspx?t=" & Timer, False
    
13.     .send
    
14.     myHTML.body.innerHTML = .responseText
    
15.     Set myTable = myHTML.getElementByID("ctl00_ContentPlaceHolder1_uc_DgFusaQuote1_dgData")
    
16.     i = 1
    
17.     For Each myRow In myTable.Rows
    
18.         j = 1
    
19.         For Each myCell In myRow.Cells
    
20.             myArr(i, j) = myCell.innerText
    
21.             j = j + 1
    
22.         Next
    
23.         i = i + 1
    
24.     Next
    
25. End With
    
26. 
    
27. Range("A5").Resize(55, 15).Value = myArr
    
28. 
    
29. Set myXML = Nothing
    
30. Erase myArr
    
31. End Sub
    
32. Sub Opt()
    
33. 
    
34. Dim myXML As Object
    
35. Set myXML = CreateObject("Microsoft.XMLHTTP")
    
36. 
    
37. Dim myHTML As Object
    
38. Set myHTML = CreateObject("HTMLFile")
    
39. 
    
40. ReDim myArr(1 To 30, 1 To 13)
    
41. 
    
42. With myXML
    
43.     .Open "GET", "http://info512.taifex.com.tw/Future/OptQuote_Norl.aspx?t=" & Timer, False
    
44.     .send
    
45.     myHTML.body.innerHTML = .responseText
    
46.     Set myTable = myHTML.getElementByID("ctl00_ContentPlaceHolder1_uc_DgOptQuote1_UpdatePanel1").getElementsByTagName("table")(0)
    
47.     i = 1
    
48.     For Each myRow In myTable.Rows
    
49.         j = 1
    
50.         For Each myCell In myRow.Cells
    
51.             myArr(i, j) = myCell.innerText
    
52.             j = j + 1
    
53.         Next
    
54.         i = i + 1
    
55.     Next
    
56. End With
    
57. 
    
58. Range("R5").Resize(30, 13).Value = myArr
    
59. 
    
60. Set myXML = Nothing
    
61. Erase myArr
    
62. End Sub

複製代碼

a5007185

回復 1# 7777

初步判定，
就算手動全選複製一樣會出現同樣的問題，
建議採用關鍵字複製原始文本，
(可參考一些爬蟲文章)

暫時先幫到這，
等有空我再來研究研究 XD