返回列表 上一主題 發帖

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

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

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

GetDividend.rar (72.65 KB)

本帖最後由 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

TOP

joey 大

貼上上面的程式碼,就不執行了,我再試試,謝謝

TOP

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

謝謝
2013-09-17_224955.png

TOP

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

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

這樣就不會出現上面的問題

TOP

本帖最後由 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 還是 &
如果有不是數字的例"-"要如何
謝謝

GetDividend.rar (72.15 KB)

TOP

回復 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

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

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

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

  66.    End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

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

TOP

回復 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

配息測試.rar (19.29 KB)

TOP

回復 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,年度範圍
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

        靜思自在 : 閒人無樂趣,忙人無是非。
返回列表 上一主題