Board logo

標題: [發問] 請教 大大 這程式是那個地方出現問題,謝謝 [打印本頁]

作者: wufonna    時間: 2018-11-5 12:43     標題: 請教 大大 這程式是那個地方出現問題,謝謝

[attach]29643[/attach]
請教 大大 這程式是那個地方出現問題,謝謝
工作表3就只複製工作表2的網
  1. Option Explicit
  2. Dim ie As Object   '模組最頂端 Dim 供這模組的程序使用的變數
  3. Sub AllFile()
  4.     Dim i As Integer, v, Y As Integer, S As String
  5.     Set ie = CreateObject("internetexplorer.application")   '使用此方式可以免除 "設定引用項目"
  6.     With ie '縮小IE視窗
  7.         .Visible = True
  8.         .Width = 5
  9.         .Height = 5
  10.     End With

  11.     With 工作表1
  12.       Dim AR
  13.         AR = .Range("E1:M1")
  14.         .Range("E:M") = ""
  15.         .Range("E1:M1") = AR

  16. '        .Range("E2").CurrentRegion = ""            '清除工作表1,年度範圍
  17.     v = "2330"
  18.           GetDividend (v)
  19.            GetClosePrice (v)
  20.            GetIncome (v)
  21.            GetBalance (v)
  22.            GetShareholding (v)

  23.             Debug.Print v

  24. End With
  25.     With ie  'IE視窗最大化
  26.         Application.WindowState = xlMaximized
  27.         .Height = Application.Height
  28.         .Width = Application.Width
  29.         .Quit
  30.     End With
  31. End Sub

  32. Private Sub GetDividend(ByVal ss As String)     '取股利網頁

  33.     Dim rr As String, T As Date, i, ii, k, j, S As Object
  34.     'On Error Resume Next '程式的執行沒有預期的錯誤,此行可不用.
  35.     T = Time
  36.     rr = "http://pscnetinvest.moneydj.com.tw/z/zc/zcc/zcc_" & ss & ".djhtm"
  37.     With ie
  38.         .Navigate rr
  39.         Do While .readyState <> 4                          '等待網頁下載完畢
  40.               DoEvents
  41.               If Time >= T + #12:00:03 AM# Then
  42.                 DoEvents
  43.                 Application.SendKeys "~"                    '股票代號錯誤,網頁會有訊息,須按確定,才可繼續下面股票代號
  44.                
  45.                
  46.                 Exit Do
  47.               End If
  48.         Loop
  49.         Do
  50.         Set S = .Document.getElementsByTagName("table")(2) ' 新的 table 4
  51.         Loop Until Not S Is Nothing

  52.         With 工作表2
  53.             .UsedRange.Clear
  54.             For i = 0 To S.Rows.Length - 1      '寫入資料
  55.                 k = k + 1
  56.                     For ii = 0 To S.Rows(i).Cells.Length - 1  ' S.Rows(i).Cells.Length - 1 才是正確
  57.                     .Cells(k, ii + 1) = S.Rows(i).Cells(ii).innerText
  58.                     DoEvents
  59.                     Next
  60.             Next
  61.         End With
  62.     End With
  63. End Sub

  64. Private Sub GetClosePrice(ByVal ss As String) ' 取基本資料

  65.     Dim rr As String, T As Date, i, ii, k, j, S As Object
  66.     'On Error Resume Next '程式的執行沒有預期的錯誤,此行可不用.
  67.     T = Time
  68.     'rr = "http://dj.mybank.com.tw/z/zc/zca/zca_" & ss & ".asp.htm" '取(基本資料) 收盤價 本益比 負債比 網頁
  69.     rr = "http://pscnetinvest.moneydj.com.tw/z/zc/zca/zca_" & ss & ".djhtm"
  70.     With ie
  71.         .Navigate rr
  72.         Do While .readyState <> 4                          '等待網頁下載完畢
  73.               DoEvents
  74.               If Time >= T + #12:00:03 AM# Then
  75.                 DoEvents
  76.                 Application.SendKeys "~"                    '股票代號錯誤,網頁會有訊息,須按確定,才可繼續下面股票代號

  77.                 Exit Do
  78.               End If
  79.         Loop
  80.         Do
  81.         Set S = .Document.getElementsByTagName("table")(2) ' 新的 table 4
  82.         Loop Until Not S Is Nothing

  83.         With 工作表3
  84.             .UsedRange.Clear
  85.             For i = 0 To S.Rows.Length - 1      '寫入資料
  86.                 k = k + 1
  87.                     For ii = 0 To S.Rows(i).Cells.Length - 1  ' S.Rows(i).Cells.Length - 1 才是正確
  88.                     .Cells(k, ii + 1) = S.Rows(i).Cells(ii).innerText
  89.                     DoEvents
  90.                     Next
  91.             Next
  92.         End With
  93.     End With
  94. End Sub


  95. Private Sub GetIncome(ByVal ss As String)     '取損益表(年表)網頁

  96.     Dim rr As String, T As Date, i, ii, k, j, S As Object
  97.     T = Time
  98.     'rr = "http://yamstock.megatime.com.tw/asp/stockinfo/GetReport.asp?Select_Table=html\YFinain\&StockID=" & ss     '取損益表(年表)網頁
  99.    
  100.    
  101.     rr = "http://pscnetinvest.moneydj.com.tw/z/zc/zcq/zcqa_" & ss & ".djhtm"

  102.     With ie
  103.         .Navigate rr
  104.         Do While .readyState <> 4                          '等待網頁下載完畢
  105.               DoEvents
  106.               If Time >= T + #12:00:03 AM# Then
  107.                 DoEvents
  108.                 Application.SendKeys "~"                    '股票代號錯誤,網頁會有訊息,須按確定,才可繼續下面股票代號
  109.                
  110.                 Exit Do
  111.               End If
  112.         Loop
  113.         Do
  114.         Set S = .Document.getElementsByTagName("table")(2) ' 新的 table 4
  115.         Loop Until Not S Is Nothing

  116.         With 工作表4
  117.             .UsedRange.Clear
  118.             For i = 0 To S.Rows.Length - 1      '寫入資料
  119.                 k = k + 1
  120.                 'For j = 0 To S.Rows(i).Length - 1  '這行是錯誤的 也是多餘的迴圈
  121.                    '用 On Error Resume Next 使程式繼續執行
  122.                     For ii = 0 To S.Rows(i).Cells.Length - 1  ' S.Rows(i).Cells.Length - 1 才是正確
  123.                     .Cells(k, ii + 1) = S.Rows(i).Cells(ii).innerText
  124.                     DoEvents
  125.                     Next
  126.                 'Next
  127.             Next
  128.         End With
  129.     End With
  130. End Sub

  131. Private Sub GetBalance(ByVal ss As String)     '取資產負債表(年表)網頁

  132.     Dim rr As String, T As Date, i, ii, k, j, S As Object
  133.     'On Error Resume Next '程式的執行沒有預期的錯誤,此行可不用.
  134.     T = Time
  135.    
  136.     rr = "http://pscnetinvest.moneydj.com.tw/z/zc/zcp/zcpb/zcpb_" & ss & ".djhtm"
  137.     With ie
  138.         .Navigate rr
  139.         Do While .readyState <> 4                          '等待網頁下載完畢
  140.               DoEvents
  141.               If Time >= T + #12:00:03 AM# Then
  142.                 DoEvents
  143.                 Application.SendKeys "~"                    '股票代號錯誤,網頁會有訊息,須按確定,才可繼續下面股票代號
  144.                
  145.                 Exit Do
  146.               End If
  147.         Loop
  148.         Do
  149.         Set S = .Document.getElementsByTagName("table")(2) ' 新的 table 4
  150.         Loop Until Not S Is Nothing


  151.         With 工作表5
  152.             .UsedRange.Clear
  153.             For i = 0 To S.Rows.Length - 1      '寫入資料
  154.                 k = k + 1
  155.                     For ii = 0 To S.Rows(i).Cells.Length - 1  ' S.Rows(i).Cells.Length - 1 才是正確
  156.                     .Cells(k, ii + 1) = S.Rows(i).Cells(ii).innerText
  157.                     DoEvents
  158.                     Next
  159.             Next
  160.         End With
  161.     End With
  162. End Sub
  163. Private Sub GetShareholding(ByVal ss As String)     '取董監持股網頁

  164.     Dim rr As String, T As Date, i, ii, k, j, S As Object
  165.     'On Error Resume Next '程式的執行沒有預期的錯誤,此行可不用.
  166.     T = Time
  167.     rr = "http://pscnetinvest.moneydj.com.tw/z/zc/zcj/zcj_" & ss & ".djhtm"     '取董監持股網頁
  168.     With ie
  169.         .Navigate rr
  170.         Do While .readyState <> 4                          '等待網頁下載完畢
  171.               DoEvents
  172.               If Time >= T + #12:00:03 AM# Then
  173.                 DoEvents
  174.                 Application.SendKeys "~"                    '股票代號錯誤,網頁會有訊息,須按確定,才可繼續下面股票代號
  175.                
  176.                 Exit Do
  177.               End If
  178.         Loop
  179.         Do
  180.         Set S = .Document.getElementsByTagName("table")(3) ' 新的 table 4
  181.         Loop Until Not S Is Nothing

  182.         With 工作表6
  183.             .UsedRange.Clear
  184.             For i = 0 To S.Rows.Length - 1      '寫入資料
  185.                 k = k + 1
  186.                     For ii = 0 To S.Rows(i).Cells.Length - 1  ' S.Rows(i).Cells.Length - 1 才是正確
  187.                     .Cells(k, ii + 1) = S.Rows(i).Cells(ii).innerText
  188.                     DoEvents
  189.                     Next
  190.             Next
  191.         End With
  192.     End With
  193. End Sub
複製代碼

作者: faye59    時間: 2018-11-6 00:40

回復 1# wufonna


    研究了一下,
本來想照我的方式重寫,
看了覺得有點麻煩...(不好意思)
所以直接改你的版本。

如果沒猜錯的話是你的私用程序沒有跟上網頁資料,
所以有不同步的地方才導致"沒有權限" ".Navigate視窗失敗"...等狀況
我把你每個程序都改成新開啟網頁(為了找盲點),
然後已經連續執行10次都沒有跳出錯誤訊息。
記得以前我也碰過類似問題(怎麼修正的也忘了),
大概修一修編寫邏輯就好了。
你在自己看一下。

另外我把你網頁最小化改成背景執行Web。
(確保程序沒錯在False,測試中請True,否則中斷程式後從工作管理員手動關閉背景殘留IE)
作者: wufonna    時間: 2018-11-6 12:53

本帖最後由 wufonna 於 2018-11-6 12:55 編輯

回復 2# faye59

謝謝 faye 大,還是會出錯,就是大大說的 Navigate錯,本來在舊版的IE上可執行,升級IE後就會錯誤。
這是原程式,麻煩 大大 看看。
作者: faye59    時間: 2018-11-8 21:10

回復 3# wufonna


應該是一樣的問題...
  1. Set ie = CreateObject("internetexplorer.application")
複製代碼
每個Private程序都加入吧~

另外你的Alert訊息修改一下會更好,
我會用這個去控制訊息式窗:
  1. Set wshshell = CreateObject("wscript.shell")
  2. Do
  3.     ret = wshshell.AppActivate("網頁訊息")
  4. Loop Until ret = True
  5. Application.Wait Now + 2 / 86400
  6. ret = wshshell.AppActivate("網頁訊息")
  7.     If ret = True Then
  8.         ret = wshshell.AppActivate("網頁訊息")'"網頁訊息"這文字需要改成你警告視窗的Title
  9.         Application.Wait Now + 2 / 86400
  10.         wshshell.SendKeys "{enter}"
  11.     End If
  12. Application.Wait Now + 2 / 86400
  13. Do While .readystate <> 4 Or .busy: DoEvents: Loop
複製代碼
我記得這是麻辣家組某位先進提供的方式,
平常用不到,
但需要用上時真的很好用,
這段程式碼是先偵測警告訊息再把警告訊息置頂,
這樣在SendKeys "{enter}"能確保正確按下。
作者: wufonna    時間: 2018-11-15 14:16

回復 4# faye59

謝謝 大大
大大 這程式是忽略錯的嗎?
我改回ie8了
測試可能是 table 的頭包在form內不能執行   
http://pscnetinvest.moneydj.com.tw/z/zc/zcq/zcqa_2330.djhtm
這網頁沒包在內就可以
http://pscnetinvest.moneydj.com.tw/z/zc/zcq/zcqa0_2330.djhtm

用版主大 http://forum.twbts.com/thread-12273-1-1.html
的測試可以,請教可用 div 區塊嗎,因div 沒包在form內,還是是因別的原因,謝謝
作者: faye59    時間: 2018-11-16 20:28

回復 5# wufonna


    不是忽略錯誤哦!!
而是把Alert訊息選擇,
讓ENTER不會按錯地方。
作者: wufonna    時間: 2019-1-15 21:13

放棄了還是找不到原因,用 GBKEE 超版大大 msxml2.xmlhttp 的方法可以用了,謝謝
http://forum.twbts.com/thread-21270-1-2.html
  1. Option Explicit

  2. Dim ie As Object   '模組最頂端 Dim 供這模組的程序使用的變數
  3. Sub AllFile()
  4.     Dim i As Integer, v, Y As Integer, S As String
  5.     Set ie = CreateObject("internetexplorer.application")   '使用此方式可以免除 "設定引用項目"
  6.     With ie '縮小IE視窗
  7.         .Visible = True
  8.         .Width = 5
  9.         .Height = 5
  10.     End With

  11.     With 工作表1
  12.       Dim AR
  13.         AR = .Range("E1:M1")
  14.         .Range("E:M") = ""
  15.         .Range("E1:M1") = AR

  16. '        .Range("E2").CurrentRegion = ""            '清除工作表1,年度範圍
  17.         For i = 2 To .Range("A" & .Rows.Count).End(xlUp).Row
  18.             v = .Cells(i, 1).Value
  19. '''''
  20.           GetDividend (v)
  21.            GetClosePrice (v)
  22.            GetIncome (v)
  23.            GetBalance (v)
  24.            GetShareholding (v)

  25.           .Cells(i, 5).Value = 工作表2.Cells(5, 2).Value
  26.           .Cells(i, 6).Value = 工作表2.Cells(5, 3).Value
  27.           .Cells(i, 7).Value = 工作表3.Cells(2, 8).Value
  28.           .Cells(i, 8).Value = .Cells(i, 5).Value / .Cells(i, 7).Value   '現金殖利率
  29.             On Error Resume Next
  30. '          .Cells(i, 8).NumberFormatLocal = "0.00%"
  31.           .Cells(i, 9).Value = 工作表4.Cells(66, 2).Value / 工作表5.Cells(94, 2).Value 'ROE%
  32.             On Error Resume Next
  33.           .Cells(i, 10).Value = 工作表3.Cells(4, 2).Value '本益比
  34.           .Cells(i, 11).Value = 工作表3.Cells(12, 4).Value '股價淨值比
  35.           .Cells(i, 12).Value = 工作表3.Cells(11, 4).Value '負債比%
  36. '          .Cells(i, 12).NumberFormatLocal = "0.00%"
  37.           .Cells(i, 13).Value = 工作表6.Cells(3, 4).Value '董監持股%
  38. '          .Cells(i, 13).NumberFormatLocal = "0.00%"


  39.             Debug.Print v
  40.         Next
  41.     End With
  42.     With ie  'IE視窗最大化
  43.         Application.WindowState = xlMaximized
  44.         .Height = Application.Height
  45.         .Width = Application.Width
  46.         .Quit
  47.     End With
  48. End Sub

  49. Public Function MyFile(v As Integer, i As Integer)
  50.   '   Dim i As Integer, v, Y As Integer, S As String
  51.     Set ie = CreateObject("internetexplorer.application")   '使用此方式可以免除 "設定引用項目"
  52.     With ie '縮小IE視窗
  53.         .Visible = True
  54.         .Width = 5
  55.         .Height = 5
  56.     End With
  57.     With 工作表1
  58.            .Range("E" & v & ":M" & v) = ""
  59. '        .Range("E2").CurrentRegion = ""            '清除工作表1,年度範圍
  60.             v = .Cells(i, 1).Value

  61.            GetDividend (v)
  62.            GetClosePrice (v)
  63.            GetIncome (v)
  64.            GetBalance (v)
  65.            GetShareholding (v)

  66.           .Cells(i, 5).Value = 工作表2.Cells(5, 2).Value
  67.           .Cells(i, 6).Value = 工作表2.Cells(5, 3).Value
  68.           .Cells(i, 7).Value = 工作表3.Cells(2, 8).Value
  69.           .Cells(i, 8).Value = .Cells(i, 5).Value / .Cells(i, 7).Value   '現金殖利率
  70.             On Error Resume Next
  71. '          .Cells(i, 8).NumberFormatLocal = "0.00%"
  72.           .Cells(i, 9).Value = 工作表4.Cells(66, 2).Value / 工作表5.Cells(94, 2).Value 'ROE%
  73.             On Error Resume Next
  74.           .Cells(i, 10).Value = 工作表3.Cells(4, 2).Value '本益比
  75.           .Cells(i, 11).Value = 工作表3.Cells(12, 4).Value '股價淨值比
  76.           .Cells(i, 12).Value = 工作表3.Cells(11, 4).Value '負債比%
  77. '          .Cells(i, 12).NumberFormatLocal = "0.00%"
  78.           .Cells(i, 13).Value = 工作表6.Cells(3, 4).Value '董監持股%
  79. '          .Cells(i, 13).NumberFormatLocal = "0.00%"


  80.     End With

  81.     With ie  'IE視窗最大化
  82.         Application.WindowState = xlMaximized
  83.         .Height = Application.Height
  84.         .Width = Application.Width
  85.         .Quit
  86.     End With
  87. End Function

  88. Private Sub GetDividend(ByVal ss As String)     '取股利網頁
  89.   Dim strText As String
  90.   Dim i As Integer, j As Integer, xTable As Object
  91.   With CreateObject("msxml2.xmlhttp")
  92.     .Open "GET", "http://pscnetinvest.moneydj.com.tw/z/zc/zcc/zcc_" & ss & ".djhtm", False
  93.     .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
  94.     .send
  95.     strText = BinToStr(.responseBody, "BIG5") '要注意網頁編碼
  96.   End With
  97.   With CreateObject("htmlfile")
  98.         .Write strText
  99.         Set xTable = .all.tags("table")(2)
  100.         With 工作表2
  101.             .Cells.Clear
  102.             For i = 0 To xTable.Rows.Length - 1
  103.                 For j = 0 To xTable.Rows(i).Cells.Length - 1
  104.                     .Cells(i + 1, j + 1) = xTable.Rows(i).Cells(j).innertext
  105.                 Next
  106.             Next
  107.         End With
  108.   End With
  109. End Sub

  110. Private Sub GetClosePrice(ByVal ss As String) ' 取基本資料
  111.   Dim strText As String
  112.   Dim i As Integer, j As Integer, xTable As Object
  113.   With CreateObject("msxml2.xmlhttp")
  114.     .Open "GET", "http://pscnetinvest.moneydj.com.tw/z/zc/zca/zca_" & ss & ".djhtm", False
  115.     .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
  116.     .send
  117.     strText = BinToStr(.responseBody, "BIG5") '要注意網頁編碼
  118.   End With
  119.   With CreateObject("htmlfile")
  120.         .Write strText
  121.         Set xTable = .all.tags("table")(2)
  122.         With 工作表3
  123.             .Cells.Clear
  124.             For i = 0 To xTable.Rows.Length - 1
  125.                 For j = 0 To xTable.Rows(i).Cells.Length - 1
  126.                     .Cells(i + 1, j + 1) = xTable.Rows(i).Cells(j).innertext
  127.                 Next
  128.             Next
  129.         End With
  130.   End With
  131. End Sub


  132. Private Sub GetIncome(ByVal ss As String)     '取損益表(年表)網頁
  133.   Dim strText As String
  134.   Dim i As Integer, j As Integer, xTable As Object
  135.   With CreateObject("msxml2.xmlhttp")
  136.     .Open "GET", "http://kgieworld.moneydj.com/z/zc/zcq/zcqa/zcqa_" & ss & ".djhtm", False
  137.     .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
  138.     .send
  139.     strText = BinToStr(.responseBody, "BIG5") '要注意網頁編碼
  140.   End With
  141.   With CreateObject("htmlfile")
  142.         .Write strText
  143.         Set xTable = .all.tags("table")(2)
  144.         With 工作表4
  145.             .Cells.Clear
  146.             For i = 0 To xTable.Rows.Length - 1
  147.                 For j = 0 To xTable.Rows(i).Cells.Length - 1
  148.                     .Cells(i + 1, j + 1) = xTable.Rows(i).Cells(j).innertext
  149.                 Next
  150.             Next
  151.         End With
  152.   End With
  153. End Sub

  154. Private Sub GetBalance(ByVal ss As String)     '取資產負債表(年表)網頁
  155.   Dim strText As String
  156.   Dim i As Integer, j As Integer, xTable As Object
  157.   With CreateObject("msxml2.xmlhttp")
  158.     .Open "GET", "http://kgieworld.moneydj.com/z/zc/zcp/zcpb/zcpb_" & ss & ".djhtm", False
  159.     .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
  160.     .send
  161.     strText = BinToStr(.responseBody, "BIG5") '要注意網頁編碼
  162.   End With
  163.   With CreateObject("htmlfile")
  164.         .Write strText
  165.         Set xTable = .all.tags("table")(2)
  166.         With 工作表5
  167.             .Cells.Clear
  168.             For i = 0 To xTable.Rows.Length - 1
  169.                 For j = 0 To xTable.Rows(i).Cells.Length - 1
  170.                     .Cells(i + 1, j + 1) = xTable.Rows(i).Cells(j).innertext
  171.                 Next
  172.             Next
  173.         End With
  174.   End With
  175. End Sub
  176. Private Sub GetShareholding(ByVal ss As String)     '取董監持股網頁
  177.   Dim strText As String
  178.   Dim i As Integer, j As Integer, xTable As Object
  179.   With CreateObject("msxml2.xmlhttp")
  180.     .Open "GET", "http://pscnetinvest.moneydj.com.tw/z/zc/zcj/zcj_" & ss & ".djhtm", False
  181.     .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
  182.     .send
  183.     strText = BinToStr(.responseBody, "BIG5") '要注意網頁編碼
  184.   End With
  185.   With CreateObject("htmlfile")
  186.         .Write strText
  187.         Set xTable = .all.tags("table")(3)
  188.         With 工作表6
  189.             .Cells.Clear
  190.             For i = 0 To xTable.Rows.Length - 1
  191.                 For j = 0 To xTable.Rows(i).Cells.Length - 1
  192.                     .Cells(i + 1, j + 1) = xTable.Rows(i).Cells(j).innertext
  193.                 Next
  194.             Next
  195.         End With
  196.   End With
  197. End Sub
  198. Function BinToStr(arrBin, strChrs)
  199.     With CreateObject("ADODB.Stream")
  200.         .Type = 2
  201.         .Open
  202.         .Writetext arrBin
  203.         .Position = 0
  204.         .Charset = strChrs
  205.         BinToStr = .ReadText
  206.         .Close
  207.     End With
  208. End Function
複製代碼





歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)