123
返回列表 上一主題 發帖

[發問] 請問這可設定等幾秒沒開網頁或網頁錯誤就執行下一筆嗎，謝謝

wufonna

帖子
161 
主題
26 
精華
0 
積分
187 
點名
0  
作業系統
xp 
軟體版本
office 2010 
閱讀權限
20 
性別
男 
來自
TW 
註冊時間
2011-1-2 
最後登錄
2022-2-16 
21# 跳轉到 »
發表於 2014-9-4 10:24 | 只看該作者
回復 16# GBKEE
請教 G 大大
我改了一些資料 有些資料還收不到
請 G 大 看那裡要改的
謝謝
  1. Dim ie As Object   '模組最頂端 Dim 供這模組的程序使用的變數
  2. Sub AllFile()
  3.     Dim i As Integer, v, Y As Integer, S As String
  4.     Set ie = CreateObject("internetexplorer.application")   '使用此方式可以免除 "設定引用項目"
  5.     With ie '縮小IE視窗
  6.         .Visible = True
  7.         .Width = 5
  8.         .Height = 5
  9.     End With
  10.     With 工作表1
  11.       Dim AR
  12.         AR = .Range("E1:G1")
  13.         .Range("E:G") = ""
  14.         .Range("E1:G1") = 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.             GetDividend (v)
  20.           .Cells(i, 5).Value = 工作表2.Cells(2, 2).Value
  21.            .Cells(i, 6).Value = 工作表2.Cells(2, 5).Value
  22.            GetClosePrice (v)
  23.            .Cells(i, 7).Value = 工作表3.Cells(2, 8).Value
  24.             
  25.         Next
  26.     End With
  27.     With ie  'IE視窗最大化
  28.         Application.WindowState = xlMaximized
  29.         .Height = Application.Height
  30.         .Width = Application.Width
  31.         .Quit
  32.     End With
  33. End Sub
  34. 'Private Sub GetDividend(ByVal ss As String)


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

  39.     Dim rr As String, T As Date, i, ii, k, j, S As Object
  40.     'On Error Resume Next '程式的執行沒有預期的錯誤,此行可不用.
  41.     T = Time
  42.     rr = "http://dj.mybank.com.tw/z/zc/zcc/zcc_" & ss & ".asp.htm"
  43.     With ie
  44.         .Navigate rr
  45.         Do While .readyState <> 4                          '等待網頁下載完畢
  46.               DoEvents
  47.               If Time >= T + #12:00:03 AM# Then            '等待8秒 3秒太少會誤錯改8妙
  48.                 DoEvents
  49.                 Application.SendKeys "~"                    '股票代號錯誤,網頁會有訊息,須按確定,才可繼續下面股票代號
  50.                
  51.                 Exit Do
  52.               End If
  53.         Loop
  54.         ''***不是等待8秒 3秒太少會誤錯改8妙 ***
  55.         Do
  56.         Set S = .Document.getElementsByTagName("table")(3) ' 新的 table 4
  57.         Loop Until Not S Is Nothing
  58.         '*** 勝一 沒捉到 ????
  59.         '*** 因程式運行太快 , S Is Nothing, S 尚未指定為.Document.getElementsByTagName("table")(4)
  60.         '*** 程式已經執行下一行, With 工作表2 的程式碼

  62.         With 工作表2
  63.             .UsedRange.Clear
  64.             For i = 0 To S.Rows.Length - 1      '寫入資料
  65.                 k = k + 1
  66.                 'For j = 0 To S.Rows(i).Length - 1  '這行是錯誤的 也是多餘的迴圈
  67.                    '用 On Error Resume Next 使程式繼續執行
  68.                     For ii = 0 To S.Rows(i).Cells.Length - 1  ' S.Rows(i).Cells.Length - 1 才是正確
  69.                     .Cells(k, ii + 1) = S.Rows(i).Cells(ii).innerText
  70.                     DoEvents
  71.                     Next
  72.                 'Next
  73.             Next
  74.         End With
  75.     End With
  76. End Sub

  78. Private Sub GetClosePrice(ByVal ss As String) ' 取收盤價網頁
  79.     Dim rr As String, T As Date, i, ii, k, j, S As Object
  80.     'On Error Resume Next '程式的執行沒有預期的錯誤,此行可不用.
  81.     T = Time
  82.     rr = "https://djinfo.cathaysec.com.tw/Z/ZC/ZCX/ZCXNEWCATHAYSEC.DJHTM?A=" & ss
  83.     With ie
  84.         .Navigate rr
  85.         Do While .readyState <> 4                          '等待網頁下載完畢
  86.               DoEvents
  87.               If Time >= T + #12:00:03 AM# Then            '等待8秒 3秒太少會誤錯改8妙
  88.                 DoEvents
  89.                 Application.SendKeys "~"                    '股票代號錯誤,網頁會有訊息,須按確定,才可繼續下面股票代號
  90.                
  91.                 Exit Do
  92.               End If
  93.         Loop
  94.         ''***不是等待8秒 3秒太少會誤錯改8妙 ***
  95.         Do
  96.         Set S = .Document.getElementsByTagName("table")(2) ' 新的 table 4
  97.         Loop Until Not S Is Nothing
  98.         '*** 勝一 沒捉到 ????
  99.         '*** 因程式運行太快 , S Is Nothing, S 尚未指定為.Document.getElementsByTagName("table")(4)
  100.         '*** 程式已經執行下一行, With 工作表2 的程式碼

  102.         With 工作表3
  103.             .UsedRange.Clear
  104.             For i = 0 To S.Rows.Length - 1      '寫入資料
  105.                 k = k + 1
  106.                 'For j = 0 To S.Rows(i).Length - 1  '這行是錯誤的 也是多餘的迴圈
  107.                    '用 On Error Resume Next 使程式繼續執行
  108.                     For ii = 0 To S.Rows(i).Cells.Length - 1  ' S.Rows(i).Cells.Length - 1 才是正確
  109.                     .Cells(k, ii + 1) = S.Rows(i).Cells(ii).innerText
  110.                     DoEvents
  111.                     Next
  112.                 'Next
  113.             Next
  114.         End With
  115.     End With
  116. End Sub
複製代碼

配息測試-3.rar (29.12 KB)

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
22#
發表於 2014-9-4 16:06 | 只看該作者
本帖最後由 GBKEE 於 2014-9-4 16:25 編輯

回復 21# wufonna
試試看
  1. Option Explicit
  2. Dim ie As Object   '模組最頂端 Dim 供這模組的程序使用的變數
  3. Dim AR()
  4. Sub AllFile()
  5.     Dim i As Integer
  6.     Set ie = CreateObject("internetexplorer.application")   '使用此方式可以免除 "設定引用項目"
  7.     With 工作表1
  8.         AR = .Range("E1:G1")
  9.         .Range("E:G") = ""
  10.         .Range("E1:G1") = AR
  11.         For i = 2 To .Range("A" & .Rows.Count).End(xlUp).Row
  12.            ReDim AR(1 To 3)
  13.            Application.StatusBar = .Cells(i, 1) & "  " & .Cells(i, 2) & " 讀取中..."
  14.             GetDividend .Cells(i, 1), 3
  15.             GetDividend .Cells(i, 1), 2
  16.             .Range("E1:G1").Offset(i - 1) = AR
  17.         Next
  18.     End With
  19.     ie.Quit
  20. End Sub
  21. Private Sub GetDividend(ByVal ss As String, ByVal table As Integer)
  22.     Dim rr As String, S As Object
  23.     If table = 3 Then
  24.         rr = "http://dj.mybank.com.tw/z/zc/zcc/zcc_" & ss & ".asp.htm"                '股利網頁
  25.     ElseIf table = 2 Then
  26.         rr = "https://djinfo.cathaysec.com.tw/Z/ZC/ZCX/ZCXNEWCATHAYSEC.DJHTM?A=" & ss '收盤價網頁
  27.     End If
  28.     With ie
  29.         .Navigate rr
  30.         Do While .readyState <> 4 Or .Busy                        '等待網頁下載完畢
  31.               DoEvents
  32.         Loop
  33.         With .document.BODY
  34.            If InStr(.INNERTEXT, "個股代碼錯誤") Or InStr(.INNERTEXT, "無此股票資料") Then
  35.                 MsgBox .INNERTEXT
  36.                 Exit Sub
  37.            End If
  38.         End With
  39.         Do
  40.         Set S = .document.getElementsByTagName("table")(table)   ' 新的 table 4
  41.         Loop Until Not S Is Nothing
  42.         If table = 3 Then
  43.             AR(1) = S.Rows(1).Cells(1).INNERTEXT            '現金股利
  44.             AR(2) = S.Rows(1).Cells(4).INNERTEXT            '股票股利
  45.         ElseIf table = 2 Then
  46.             AR(3) = S.Rows(1).Cells(7).INNERTEXT            '收盤價
  47.         End If
  48.     End With
  49. End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

wufonna

帖子
161 
主題
26 
精華
0 
積分
187 
點名
0  
作業系統
xp 
軟體版本
office 2010 
閱讀權限
20 
性別
男 
來自
TW 
註冊時間
2011-1-2 
最後登錄
2022-2-16 
23#
發表於 2014-9-4 17:23 | 只看該作者
回復 22# GBKEE

感謝 GBKEE 大
程式跑了幾次都能捉到
程式碼我研究看看 不會再向 GBKEE 大大請教
謝謝 ^_^

TOP

wufonna

帖子
161 
主題
26 
精華
0 
積分
187 
點名
0  
作業系統
xp 
軟體版本
office 2010 
閱讀權限
20 
性別
男 
來自
TW 
註冊時間
2011-1-2 
最後登錄
2022-2-16 
24#
發表於 2022-2-12 20:07 | 只看該作者
回復 1# wufonna
改了程式內容

請教程式沒加入這段 On Error Resume Next '下行會出錯，加入這行，未知原因。 會錯誤是網頁有空格的關溪嗎?
請教大大如何修改 謝謝
  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.     Dim z As Integer

  7.     With 工作表1
  8.         Dim AR
  9.            AR = .Range("C1:J1")
  10.           .Range("C:J") = ""
  11.           .Range("C1:J1") = AR
  12.           z = 0
  13.         For i = 2 To .Range("A" & .Rows.Count).End(xlUp).Row
  14.      
  15.            v = .Cells(i, 1).Value
  16.             GetDividend (v)
  17.              .Cells(i, 3).Resize(1, 7).Value = 工作表2.Cells(7, 1).Resize(1, 7).Value

  19.              If 工作表2.Cells(7, 5).Value > 0 Then
  20.                .Cells(i, 10).Value = 1
  21.                z = z + 1
  22.               Else
  23.                .Cells(i, 10).Value = 0
  24.               End If
  25.                             If 工作表2.Cells(7, 5).Value > 0 And 工作表2.Cells(8, 5).Value > 0 And 工作表2.Cells(9, 5).Value > 0 Then 'K(營收連3個月正成長)
  26.                 .Cells(i, 11).Value = 1
  27.               Else
  28.                 .Cells(i, 11).Value = 0
  29.               End If
  30.         Next
  31. '            MsgBox "共有" & z & "家正成長"
  32. .Cells(1, 10).Value = "去年同期年增率" & Split(Date, "/")(1) - 1 & "月份" & .Range("A" & .Rows.Count).End(xlUp).Row & "家共有" & z & "家正成長"
  33.    
  34.     End With

  36. End Sub

  38. Public Function MyFile(v As Integer, i As Integer)
  39.   '   Dim i As Integer, v, Y As Integer, S As String

  41.     With 工作表1
  42.            .Range("C" & v & ":J" & v) = "" '清除工作表1,年度範圍
  43.            v = .Cells(i, 1).Value
  44.             GetDividend (v)
  45.              .Cells(i, 3).Resize(1, 7).Value = 工作表2.Cells(7, 1).Resize(1, 7).Value

  47.              If 工作表2.Cells(7, 5).Value > 0 Then
  48.                .Cells(i, 10).Value = 1

  50.               Else
  51.                .Cells(i, 10).Value = 0
  52.               End If
  53.               If 工作表2.Cells(7, 5).Value > 0 And 工作表2.Cells(8, 5).Value > 0 And 工作表2.Cells(9, 5).Value > 0 Then 'k (營收連3個月正成長)
  54.                 .Cells(i, 11).Value = 1
  55.               Else
  56.                 .Cells(i, 11).Value = 0
  57.               End If
  58.               
  59.     End With

  61. End Function



  65. Private Sub GetDividend(ByVal ss As String)     '取股利網頁 '2022/2/22 換這段程式碼 在 https://www.mobile01.com/topicdetail.php?f=511&t=4737630&p=3 的21樓
  66. Dim URL, HTMLsourcecode, GetXml, Table
  67. Dim i As Integer, j As Integer
  68. Set HTMLsourcecode = CreateObject("htmlfile")
  69. Set GetXml = CreateObject("msxml2.xmlhttp")
  70. URL = "http://pscnetinvest.moneydj.com.tw/z/zc/zch/zch_" & ss & ".djhtm"
  71. With GetXml
  72. .Open "GET", URL, False
  73. .setRequestHeader "Cache-Control", "no-cache"
  74. .setRequestHeader "Pragma", "no-cache"
  75. .setRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT"
  76. .send

  78. HTMLsourcecode.body.innerhtml = .responsetext
  79. On Error Resume Next '下行會出錯，加入這行，未知原因。
  80. Set Table = HTMLsourcecode.all.tags("table")(2).Rows
  81. For i = 0 To Table.Length - 1
  82. For j = 0 To Table(i).Cells.Length - 1
  83. 工作表2.Cells(i + 1, j + 1) = Table(i).Cells(j).innertext
  84. Next j
  85. Next i
  86. End With
  87. Set HTMLsourcecode = Nothing
  88. Set GetXml = Nothing
  89. End Sub
複製代碼

Annualrate-2022.rar (105.34 KB)

TOP

quickfixer

帖子
154 
主題
1 
精華
0 
積分
200 
點名
31  
作業系統
windwos 7 
軟體版本
64bit 
閱讀權限
20 
註冊時間
2017-5-29 
最後登錄
2024-11-28 
25#
發表於 2022-2-12 20:52 | 只看該作者
本帖最後由 quickfixer 於 2022-2-12 21:01 編輯

回復 24# wufonna


    玩了一下,會出錯是沒抓到資料,好像是程式跑太快,流量限制的問題,可是沒擋ip?
程式沒問題,另外做一個commandbutton,全部編號跑完後,再重抓有空白的資料
Sub test()
    With 工作表1
        For i = 2 To .Range("A" & .Rows.Count).End(xlUp).Row
只抓沒資料的編號
           If .Cells(i, 3) = "" Then
            v = .Cells(i, 1).Value
            GetDividend (v)
'這幾行code 同 AllFile ,恕刪
           End If
        Next
    End With
End Sub

TOP

wufonna

帖子
161 
主題
26 
精華
0 
積分
187 
點名
0  
作業系統
xp 
軟體版本
office 2010 
閱讀權限
20 
性別
男 
來自
TW 
註冊時間
2011-1-2 
最後登錄
2022-2-16 
26#
發表於 2022-2-12 22:16 | 只看該作者
回復 25# quickfixer


    謝謝 大大 ，我有用
  1. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  2.     Application.EnableEvents = False
  3.         If Target(1).Column = 1 And Target(1).Address(0, 0) <> "A1" Then          '在第1列
  4.             If Target(1).Value <> "" Then
  5.             
  6. '         MsgBox Target(1).Address(0, 0) & vbCrLf & vbCrLf & Target(1).Value & vbCrLf & vbCrLf & Target(1).Row
  7.             Call MyFile(Target(1).Value, Target(1).Row)
  8.             End If
  9.         End If
  10.     Application.EnableEvents = True

  12. End Sub
複製代碼
抓取個別的資料
想請教有程式取代
On Error Resume Next '下行會出錯，加入這行，未知原因。
這段程式碼嗎

TOP

quickfixer

帖子
154 
主題
1 
精華
0 
積分
200 
點名
31  
作業系統
windwos 7 
軟體版本
64bit 
閱讀權限
20 
註冊時間
2017-5-29 
最後登錄
2024-11-28 
27#
發表於 2022-2-12 22:43 | 只看該作者
本帖最後由 quickfixer 於 2022-2-12 22:45 編輯

回復 26# wufonna

沒注意到SelectionChange裡面有重抓的程式碼

出錯時    debug.print HTMLsourcecode.body.innerhtml 出現這個,沒有抓到資料


google httpcode=500
伺服器端錯誤回應
500 Internal Server Error
伺服器端發生未知或無法處理的錯誤。

可能程式跑太快,同個ip請求太多,網頁來不及處理

TOP

quickfixer

帖子
154 
主題
1 
精華
0 
積分
200 
點名
31  
作業系統
windwos 7 
軟體版本
64bit 
閱讀權限
20 
註冊時間
2017-5-29 
最後登錄
2024-11-28 
28#
發表於 2022-2-12 23:11 | 只看該作者
本帖最後由 quickfixer 於 2022-2-12 23:14 編輯

回復 27# quickfixer

我參考你給的01網址686f,加入重新下載功能,可全部跑完
  1. Private Sub GetDividend(ByVal ss As String)     '取股利網頁 '2022/2/22 換這段程式碼 在 https://www.mobile01.com/topicdetail.php?f=511&t=4737630&p=3 的21樓
  2. Dim URL, HTMLsourcecode, GetXml, Table
  3. Dim i As Integer, j As Integer, r As Integer
  4. Set HTMLsourcecode = CreateObject("htmlfile")
  5. Set GetXml = CreateObject("msxml2.xmlhttp")
  6. URL = "http://pscnetinvest.moneydj.com.tw/z/zc/zch/zch_" & ss & ".djhtm"

  8. r = 0
  9. retry:
  10. On Error Resume Next

  12. With GetXml
  13. .Open "GET", URL, False
  14. .setRequestHeader "Cache-Control", "no-cache"
  15. .setRequestHeader "Pragma", "no-cache"
  16. .setRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT"
  17. .send

  19. HTMLsourcecode.body.innerhtml = .responsetext
  20. Set Table = HTMLsourcecode.all.tags("table")(2).Rows

  22. If Err.Number <> 0 Then

  24. If r > 3 Then
  25. '超過3次,改抓下一筆,避免無限loop
  26. Exit Sub
  27. End If
  28. Debug.Print Err.Description
  29. r = r + 1
  30. On Error GoTo -1
  31. Err.Clear
  32. '等0.5秒
  33. Delaytick (0.5)
  34. GoTo retry

  36. End If
  37.             
  38. For i = 0 To Table.Length - 1
  39. For j = 0 To Table(i).Cells.Length - 1
  40. 工作表2.Cells(i + 1, j + 1) = Table(i).Cells(j).innertext
  41. Next j
  42. Next i
  43. End With
  44. Set HTMLsourcecode = Nothing
  45. Set GetXml = Nothing
  46. End Sub



  50. Sub Delaytick(setdelay As Single)
  51.    
  52.     Dim StartTime As Double, NowTime As Double
  53.     StartTime = Timer * 100
  54.     setdelay = setdelay * 100
  55.     Do
  56.       NowTime = Timer * 100
  57.       DoEvents
  58.     Loop Until NowTime - StartTime > setdelay
  59.    
  60. End Sub
複製代碼
但是你allfile裡面那個Split(Date, "/")(1) - 1
可能要改一下,有人excel日期是用-不是/
用mid可能會比較好一些

TOP

wufonna

帖子
161 
主題
26 
精華
0 
積分
187 
點名
0  
作業系統
xp 
軟體版本
office 2010 
閱讀權限
20 
性別
男 
來自
TW 
註冊時間
2011-1-2 
最後登錄
2022-2-16 
29#
發表於 2022-2-13 17:14 | 只看該作者
本帖最後由 wufonna 於 2022-2-13 17:20 編輯

回復 28# quickfixer


    謝謝 大大
之前程式可跑完，可能這兩天營收更新，網頁才有缺少資料，等網頁更新完在下載看看。
加了程式碼程式有跑完。

Image 1.jpg (145.4 KB)

Image 1.jpg

TOP

wufonna

帖子
161 
主題
26 
精華
0 
積分
187 
點名
0  
作業系統
xp 
軟體版本
office 2010 
閱讀權限
20 
性別
男 
來自
TW 
註冊時間
2011-1-2 
最後登錄
2022-2-16 
30#
發表於 2022-2-13 18:46 | 只看該作者
回復 28# quickfixer


    謝謝 大大
修改
  1. Sub test()
  2. Debug.Print Date
  3. '修改1月的前一個月便0
  4. If Split(Date, "/")(1) - 1 = 0 Then
  5. Debug.Print 12
  6. Else
  7. Debug.Print Split(Date, "/")(1) - 1
  8. End If

  10. End Sub
複製代碼

TOP

        靜思自在 : 一句溫暖的話，就像往別人身上灑香水，自己會沾到兩三滴。
123
返回列表 上一主題