12
返回列表 上一主題 發帖

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

wufonna

帖子
161 
主題
26 
精華
0 
積分
187 
點名
0  
作業系統
xp 
軟體版本
office 2010 
閱讀權限
20 
性別
男 
來自
TW 
註冊時間
2011-1-2 
最後登錄
2025-10-9 
11# 跳轉到 »
發表於 2014-9-3 21:00 | 顯示全部帖子
本帖最後由 wufonna 於 2014-9-3 21:11 編輯

回復 15# joey0415
  1. Sub 巨集1()
  2. '
  3. ' 巨集1 巨集
  4. '

  6. '
  7.     With ActiveSheet.QueryTables.Add(Connection:= _
  8.         "URL;https://djinfo.cathaysec.com.tw/Z/ZC/ZCX/ZCXNEWCATHAYSEC.DJHTM?A=2882", _
  9.         Destination:=Range("$A$1"))
  10.         .Name = "ZCXNEWCATHAYSEC.DJHTM?A=2882"
  11.         .FieldNames = True
  12.         .RowNumbers = False
  13.         .FillAdjacentFormulas = False
  14.         .PreserveFormatting = True
  15.         .RefreshOnFileOpen = False
  16.         .BackgroundQuery = True
  17.         .RefreshStyle = xlInsertDeleteCells
  18.         .SavePassword = False
  19.         .SaveData = True
  20.         .AdjustColumnWidth = True
  21.         .RefreshPeriod = 0
  22.         .WebSelectionType = xlSpecifiedTables
  23.         .WebFormatting = xlWebFormattingNone
  24.         .WebTables = "2,3"
  25.         .WebPreFormattedTextToColumns = True
  26.         .WebConsecutiveDelimitersAsOne = True
  27.         .WebSingleBlockTextImport = False
  28.         .WebDisableDateRecognition = False
  29.         .WebDisableRedirections = False
  30.         .Refresh BackgroundQuery:=False
  31.     End With
  32. End Sub
複製代碼
請教 大大 這段如何精簡程式碼
像 table 這樣
因要從中取得收盤價
謝謝 大大

TOP

wufonna

帖子
161 
主題
26 
精華
0 
積分
187 
點名
0  
作業系統
xp 
軟體版本
office 2010 
閱讀權限
20 
性別
男 
來自
TW 
註冊時間
2011-1-2 
最後登錄
2025-10-9 
12#
發表於 2014-9-4 10:16 | 顯示全部帖子
回復 19# joey0415
謝謝 大大
國泰的資料真的快多了

TOP

wufonna

帖子
161 
主題
26 
精華
0 
積分
187 
點名
0  
作業系統
xp 
軟體版本
office 2010 
閱讀權限
20 
性別
男 
來自
TW 
註冊時間
2011-1-2 
最後登錄
2025-10-9 
13#
發表於 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

wufonna

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

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

TOP

wufonna

帖子
161 
主題
26 
精華
0 
積分
187 
點名
0  
作業系統
xp 
軟體版本
office 2010 
閱讀權限
20 
性別
男 
來自
TW 
註冊時間
2011-1-2 
最後登錄
2025-10-9 
15#
發表於 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

wufonna

帖子
161 
主題
26 
精華
0 
積分
187 
點名
0  
作業系統
xp 
軟體版本
office 2010 
閱讀權限
20 
性別
男 
來自
TW 
註冊時間
2011-1-2 
最後登錄
2025-10-9 
16#
發表於 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

wufonna

帖子
161 
主題
26 
精華
0 
積分
187 
點名
0  
作業系統
xp 
軟體版本
office 2010 
閱讀權限
20 
性別
男 
來自
TW 
註冊時間
2011-1-2 
最後登錄
2025-10-9 
17#
發表於 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 
最後登錄
2025-10-9 
18#
發表於 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

        靜思自在 : 不要小看自己，因為人有無限的可能。
12
返回列表 上一主題