Board logo

標題: [發問] 請問這可設定等幾秒沒開網頁或網頁錯誤就執行下一筆嗎，謝謝 [打印本頁]
作者: wufonna    時間: 2013-9-17 18:23     標題: 請問這可設定等幾秒沒開網頁或網頁錯誤就執行下一筆嗎，謝謝

Private Sub GetDividend(ByVal ss As String)
    Dim rr As String

   rr = "http://yamstock.megatime.com.tw/asp/stockinfo/GetReport.asp?select_table=html\Ficxxx\&stockid=2412&" & ss & "&name1=D4&index1=12"     ' 正確的
    工作表2.Select
    Cells.Clear

    Set ie = CreateObject("internetexplorer.application") '使用此方式可以免除 "設定引用項目"

    With ie
        .Visible = False 'True為開啟ie, False為不開啟ie
        .Navigate rr
        Do While .ReadyState <> 4 '等待網頁開啟
        DoEvents
        Loop
        .ExecWB 17, 2 'Select All
        .ExecWB 12, 2 'Copy selection
        
        工作表2.Range("A1").Activate
        
        ActiveSheet.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:= _
            False, NoHTMLFormatting:=True
    End With

     ie.Quit
   End Sub

Sub AllFile()
Dim i As Integer, v

On Error Resume Next
For i = 2 To 工作表1.Range("A" & 工作表1.Rows.Count).End(xlUp).Row

v = 工作表1.Cells(i, 1).Value

Call GetDividend(v)
工作表1.Cells(i, 9).Value = 工作表2.Cells(34, 8).Value
Debug.Print 工作表1.Cells(i, 1).Value & " " & 工作表1.Cells(i, 2).Value

Next

End Sub
作者: joey0415    時間: 2013-9-17 21:19

本帖最後由 joey0415 於 2013-9-17 21:26 編輯

如果工作表上的你想要的某格是空字串，就跳過
instr

會出錯的地方
用On Error Resume Next

如果某網頁是空的或特殊字元也跳過

========================

網路上找到的我自己保存的如下，可以更新

                                   t1 = Timer
                                    Do Until oWin.ReadyState = 4
                                        DoEvents    '經常就在這停下不運行了
                                        If Timer > t1 + 3 Then oWin.Refresh: t1 = Timer  '這裡刷新一下，自己去調整一下多長時間刷新
                                    Loop
作者: wufonna    時間: 2013-9-17 22:41

joey 大

貼上上面的程式碼，就不執行了，我再試試，謝謝
作者: wufonna    時間: 2013-9-17 22:50

程式執行中有些訊息可忽烈，例如

謝謝
作者: joey0415    時間: 2013-9-17 23:49

不要用貼上的方法，改用例如

worksheetI("sheet1").cells(1,2)=worksheetI("sheet2").cells(1,2)

這樣就不會出現上面的問題
作者: wufonna    時間: 2013-9-17 23:57

本帖最後由 GBKEE 於 2013-9-19 08:26 編輯

網址下錯了，再重上載
Private Sub GetDividend(ByVal ss As String)
    Dim rr As String

   rr = "http://yamstock.megatime.com.tw/asp/stockinfo/GetReport.asp?select_table=html\Ficxxx\&stockid=" & ss & "&name1=D4&index1=12"     ' 正確的
    工作表2.Select
    Cells.Clear

    Set ie = CreateObject("internetexplorer.application") '使用此方式可以免除 "設定引用項目"

    With ie
        .Visible = False 'True為開啟ie, False為不開啟ie
        .Navigate rr
        Do While .ReadyState <> 4 '等待網頁開啟
        DoEvents
        Loop
        .ExecWB 17, 2 'Select All
        .ExecWB 12, 2 'Copy selection
        
        工作表2.Range("A1").Activate
        
        ActiveSheet.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:= _
            False, NoHTMLFormatting:=True
    End With

     ie.Quit
   End Sub

Sub AllFile()
Dim i As Integer, v

For i = 2 To 工作表1.Range("A" & 工作表1.Rows.Count).End(xlUp).Row



v = 工作表1.Cells(i, 1).Value

Call GetDividend(v)
工作表1.Cells(i, 9).Value = 工作表2.Cells(34, 8).Value: 工作表1.Cells(i, 10).Value = 工作表2.Cells(33, 8).Value
工作表1.Cells(i, 11).Value = 工作表2.Cells(32, 8).Value: 工作表1.Cells(i, 12).Value = 工作表2.Cells(31, 8).Value
工作表1.Cells(i, 13).Value = 工作表2.Cells(30, 8).Value: 工作表1.Cells(i, 14).Value = 工作表2.Cells(29, 8).Value
工作表1.Cells(i, 15).Value = 工作表2.Cells(28, 8).Value: 工作表1.Cells(i, 16).Value = 工作表2.Cells(27, 8).Value

If 工作表2.Cells(34, 8).Value > 0 And 工作表2.Cells(33, 8).Value > 0 And 工作表2.Cells(32, 8).Value > 0 _
And 工作表2.Cells(31, 8).Value > 0 And 工作表2.Cells(30, 8).Value > 0 And 工作表2.Cells(29, 8).Value > 0 _
And 工作表2.Cells(28, 8).Value > 0 And 工作表2.Cells(27, 8).Value > 0 Then
工作表1.Cells(i, 17).Value = 1
Else
工作表1.Cells(i, 17).Value = 0
End If

Next

End Sub

=================
請問 On Error Resume Next
要用在 FOR NEXT 下方
還是 下方

要判斷是否大於0是要用 AND 還是 &
如果有不是數字的例"-"要如何
謝謝
作者: GBKEE    時間: 2013-9-19 08:27

回復 6# wufonna
試試看
  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.     S = "I"                                                 '2005 年度起始欄位
  6.     Set ie = CreateObject("internetexplorer.application")   '使用此方式可以免除 "設定引用項目"
  7.     With ie '縮小IE視窗
  8.         .Visible = True
  9.         .Width = 5
  10.         .Height = 5
  11.     End With
  12.     With 工作表1

  14.         .Range(S & 1).CurrentRegion = ""            '清除工作表1,年度範圍
  15.         Do
  16.             .Range(S & 1).Offset(, Y) = 2005 + Y
  17.             Y = Y + 1
  18.         Loop While 2005 + Y < Year(Date)
  19.         For i = 2 To .Range("A" & .Rows.Count).End(xlUp).Row
  20.             v = .Cells(i, 1).Value
  21.             GetDividend (v)
  22.             .Cells(i, S).Resize(, Y) = Application.WorksheetFunction.Transpose(工作表2.Range("H4").Resize(Y))
  23.             If Application.Sum(.Cells(i, S).Resize(, Y)) > 1 Then
  24.                 .Cells(i, S).Offset(, Y) = 1
  25.             Else
  26.                 .Cells(i, S).Offset(, Y) = 0
  27.             End If
  28.         Next
  29.         .Range(S & 1).CurrentRegion.Replace "--", "", xlWhole
  30.     End With
  31.     With ie  'IE視窗最大化
  32.         Application.WindowState = xlMaximized
  33.         .Height = Application.Height
  34.         .Width = Application.Width
  35.         .Quit
  36.     End With
  37. End Sub
  38. Private Sub GetDividend(ByVal ss As String)

  40.     Dim rr As String, T As Date, i, ii, k, j, S
  41.     On Error Resume Next
  42.     T = Time
  43.     rr = "http://yamstock.megatime.com.tw/asp/stockinfo/GetReport.asp?select_table=html\Ficxxx\&stockid=" & ss & "&name1=D4&index1=12"     ' 正確的
  44.     With ie
  45.         .Navigate rr
  46.         Do While .ReadyState <> 4                          '等待網頁下載完畢
  47.               DoEvents
  48.               If Time >= T + #12:00:03 AM# Then            '等待3秒
  49.                 DoEvents
  50.                 Application.SendKeys "~"                    '股票代號錯誤,網頁會有訊息,須按確定,才可繼續下面股票代號
  51.                 Exit Do
  52.               End If
  53.         Loop
  54.         Set S = .Document.getelementsbytagname("table")(11)
  55.         With 工作表2
  56.             .UsedRange.Clear

  58.             For i = 0 To S.Rows.Length - 1      '寫入資料
  59.                 k = k + 1
  60.                 For j = 0 To S.Rows(i).Length - 1
  61.                     For ii = 0 To S.Rows(i).Cells.Length - 1
  62.                     .Cells(k, ii + 1) = S.Rows(i).Cells(ii).innertext
  63.                     DoEvents
  64.                     Next
  65.                 Next
  66.             Next
  67.         End With
  68.     End With

  70.    End Sub
複製代碼
作者: wufonna    時間: 2013-9-19 21:14

非常謝謝 G大
程式一次跑完，而且都捉的到資料，我要一些時日來吸收消化這些程式^_^
學生希望結合各基本面的資料，把程式作好，多多參考站內的程式，
程式真是一門藝術^0^
謝謝
作者: wufonna    時間: 2014-9-1 15:56

回復 7# GBKEE
請問 G 大大
    .Range("E2").CurrentRegion = ""            '清除工作表1,年度範圍
是不是從 E2 開始清除 怎 E1 D2 的 現金股利        股票股利 也刪了
有的資料有時捉不到
請問如何才能確保捉到
謝謝 G 大


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

'        .Range("E2").CurrentRegion = ""            '清除工作表1,年度範圍
        For i = 2 To .Range("A" & .Rows.Count).End(xlUp).Row
            v = .Cells(i, 1).Value
            GetDividend (v)
            工作表2.Range("D4").CurrentRegion.Replace "--", "", xlWhole

            .Cells(i, 5).Resize(, 2).Value = 工作表2.Cells(4, 4).Resize(, 2).Value
            
        Next
    End With
    With ie  'IE視窗最大化
        Application.WindowState = xlMaximized
        .Height = Application.Height
        .Width = Application.Width
        .Quit
    End With
End Sub
Private Sub GetDividend(ByVal ss As String)

    Dim rr As String, T As Date, i, ii, k, j, S
    On Error Resume Next
    T = Time
    rr = "http://yamstock.megatime.com.tw/asp/stockinfo/GetReport.asp?select_table=html\Ficxxx\&stockid=" & ss & "&name1=D4&index1=12"     ' 正確的
    With ie
        .Navigate rr
        Do While .ReadyState <> 4                          '等待網頁下載完畢
              DoEvents
              If Time >= T + #12:00:03 AM# Then            '等待3秒
                DoEvents
                Application.SendKeys "~"                    '股票代號錯誤,網頁會有訊息,須按確定,才可繼續下面股票代號
                Exit Do
              End If
        Loop
        Set S = .Document.getelementsbytagname("table")(4) ' 新的 table 4

        With 工作表2
            .UsedRange.Clear

            For i = 0 To S.Rows.Length - 1      '寫入資料
                k = k + 1
                For j = 0 To S.Rows(i).Length - 1
                    For ii = 0 To S.Rows(i).Cells.Length - 1
                    .Cells(k, ii + 1) = S.Rows(i).Cells(ii).innertext
                    DoEvents
                    Next
                Next
            Next
        End With
    End With

   End Sub
作者: GBKEE    時間: 2014-9-1 17:32

回復 9# wufonna
要改一下
  1.   Dim AR
  2.     With 工作表1
  3.         AR = .Range("E1:F1")
  4.         .Range("E:F") = ""
  5.         .Range("E1:F1") = AR
  6. '        .Range("E2").CurrentRegion = ""            '清除工作表1,年度範圍
複製代碼
作者: wufonna    時間: 2014-9-1 19:54

本帖最後由 wufonna 於 2014-9-1 20:00 編輯

回復 10# GBKEE

謝謝 G 大大

再請問 GBKEE  大大
有時網頁捉不到是網頁的問題 可以解決嗎
是改 Application.SendKeys "~" 嗎

還有下面是錯誤是什網頁錯誤嗎
謝謝
作者: wufonna    時間: 2014-9-1 20:18

回復 11# wufonna


    請問 G 大大 是
   If Time >= T + #12:00:08 AM# Then        
等代時間少的問題嗎 我將3秒改8秒就沒錯了
如果股票多了如何解決 謝謝
作者: GBKEE    時間: 2014-9-2 14:34

回復 12# wufonna
11#所說的錯誤,程式碼在哪發生的.
作者: wufonna    時間: 2014-9-2 17:22

回復 13# GBKEE

GBKEE 大大
程式沒有錯誤
可是有時資料沒捉到
像這次 勝一 沒捉到
謝謝
作者: joey0415    時間: 2014-9-3 11:14

本帖最後由 joey0415 於 2014-9-3 11:19 編輯

回復 14# wufonna

https://djinfo.cathaysec.com.tw/Z/ZC/ZCC/ZCC.DJHTM?A=1101

代碼變數自己改改就行
  1. Sub 巨集1()
  2. '
  3.     With ActiveSheet.QueryTables.Add(Connection:= _
  4.         "URL;https://djinfo.cathaysec.com.tw/Z/ZC/ZCC/ZCC.DJHTM?A=1101", Destination _
  5.         :=Range("$A$1"))
  6.         .WebFormatting = xlWebFormattingNone
  7.         .WebTables = "3"
  8.         .Refresh BackgroundQuery:=False
  9.         .Delete
  10.     End With
  11. End Sub
複製代碼
用這種網站抓資料比較用，不用等幾秒...

網址又清楚

yam會下載一堆沒用的東西

把所有抓下來排序一下，就知道有哪些股是沒有抓完整的，再抓一次就可以了…

通常下載都是會找穩定、速度快，純資料為最佳

參考
作者: GBKEE    時間: 2014-9-3 16:10

回復 14# wufonna
請詳看註解
  1. Private Sub GetDividend(ByVal ss As String)
  2.     Dim rr As String, T As Date, i, ii, k, j, S As Object
  3.     'On Error Resume Next '程式的執行沒有預期的錯誤,此行可不用.
  4.     T = Time
  5.     rr = "http://yamstock.megatime.com.tw/asp/stockinfo/GetReport.asp?select_table=html\Ficxxx\&stockid=" & ss & "&name1=D4&index1=12"     ' 正確的
  6.     With ie
  7.         .Navigate rr
  8.         Do While .readyState <> 4                          '等待網頁下載完畢
  9.               DoEvents
  10.               If Time >= T + #12:00:03 AM# Then            '等待8秒 3秒太少會誤錯改8妙
  11.                 DoEvents
  12.                 Application.SendKeys "~"                    '股票代號錯誤,網頁會有訊息,須按確定,才可繼續下面股票代號
  13.                
  14.                 Exit Do
  15.               End If
  16.         Loop
  17.         ''***不是等待8秒 3秒太少會誤錯改8妙 ***
  18.         Do
  19.         Set S = .Document.getElementsByTagName("table")(4) ' 新的 table 4
  20.         Loop Until Not S Is Nothing
  21.         '*** 勝一 沒捉到 ????
  22.         '*** 因程式運行太快 , S Is Nothing, S 尚未指定為.Document.getElementsByTagName("table")(4)
  23.         '*** 程式已經執行下一行, With 工作表2 的程式碼

  25.         With 工作表2
  26.             .UsedRange.Clear
  27.             For i = 0 To S.Rows.Length - 1      '寫入資料
  28.                 k = k + 1
  29.                 'For j = 0 To S.Rows(i).Length - 1  '這行是錯誤的 也是多餘的迴圈
  30.                    '用 On Error Resume Next 使程式繼續執行
  31.                     For ii = 0 To S.Rows(i).Cells.Length - 1  ' S.Rows(i).Cells.Length - 1 才是正確
  32.                     .Cells(k, ii + 1) = S.Rows(i).Cells(ii).innerText
  33.                     DoEvents
  34.                     Next
  35.                 'Next
  36.             Next
  37.         End With
  38.     End With
  39. End Sub
複製代碼
作者: wufonna    時間: 2014-9-3 20:52

回復 16# GBKEE


    謝謝 G 大大
    程式運行順暢 ^_^
   
本想二維的表單怎會有三個 FOR NEXT
正想發問

再請在 G 大大
新手如何去發現程式中沒有錯誤的變化
像程式中的
Do
        Set S = .Document.getElementsByTagName("table")(4) ' 新的 table 4
        Loop Until Not S Is Nothing
謝謝
作者: wufonna    時間: 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 這樣
因要從中取得收盤價
謝謝 大大
作者: joey0415    時間: 2014-9-4 08:17

回復 18# wufonna

其實就是錄製好後，把某行註解後，再執行，如果可以就表示該行不需行，因為錄製的通常會有很多不要的代碼
錄久了就知道…
最後加上.delete
表示取消連線
  1. Sub 巨集1()
  2.     With ActiveSheet.QueryTables.Add(Connection:= _
  3.         "URL;https://djinfo.cathaysec.com.tw/Z/ZC/ZCX/ZCXNEWCATHAYSEC.DJHTM?A=2882", _
  4.         Destination:=Range("$A$1"))
  5.         .WebFormatting = xlWebFormattingNone
  6.         .WebTables = "2,3"
  7.         .Refresh BackgroundQuery:=False
  8.         .Delete
  9.     End With
  10. End Sub
複製代碼
作者: wufonna    時間: 2014-9-4 10:16

回復 19# joey0415
謝謝 大大
國泰的資料真的快多了
作者: wufonna    時間: 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
複製代碼
[attach]19092[/attach]
作者: GBKEE    時間: 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
複製代碼
作者: wufonna    時間: 2014-9-4 17:23

回復 22# GBKEE

感謝 GBKEE 大
程式跑了幾次都能捉到
程式碼我研究看看 不會再向 GBKEE 大大請教
謝謝 ^_^
作者: wufonna    時間: 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
複製代碼
作者: quickfixer    時間: 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
作者: wufonna    時間: 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 '下行會出錯，加入這行，未知原因。
這段程式碼嗎
作者: quickfixer    時間: 2022-2-12 22:43

本帖最後由 quickfixer 於 2022-2-12 22:45 編輯

回復 26# wufonna

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

出錯時    debug.print HTMLsourcecode.body.innerhtml 出現這個,沒有抓到資料
[attach]34669[/attach]

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

可能程式跑太快,同個ip請求太多,網頁來不及處理
作者: quickfixer    時間: 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可能會比較好一些
作者: wufonna    時間: 2022-2-13 17:14

本帖最後由 wufonna 於 2022-2-13 17:20 編輯

回復 28# quickfixer


    謝謝 大大
之前程式可跑完，可能這兩天營收更新，網頁才有缺少資料，等網頁更新完在下載看看。
加了程式碼程式有跑完。
作者: wufonna    時間: 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
複製代碼




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