麻辣家族討論版版's Archiver

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

[i=s] 本帖最後由 joey0415 於 2013-9-17 21:26 編輯 [/i]

如果工作表上的你想要的某格是空字串,就跳過
[b]instr[/b]

會出錯的地方
用[b]On Error Resume Next[/b]

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

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

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

                                   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

[i=s] 本帖最後由 GBKEE 於 2013-9-19 08:26 編輯 [/i]

網址下錯了,再重上載
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

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=58625&ptid=10453]6#[/url] [i]wufonna[/i] [/b]
試試看[code]Option Explicit
Dim ie As Object   '模組最頂端 Dim 供這模組的程序使用的變數
Sub AllFile()
    Dim i As Integer, v, Y As Integer, S As String
    S = "I"                                                 '2005 年度起始欄位
    Set ie = CreateObject("internetexplorer.application")   '使用此方式可以免除 "設定引用項目"
    With ie '縮小IE視窗
        .Visible = True
        .Width = 5
        .Height = 5
    End With
    With 工作表1

        .Range(S & 1).CurrentRegion = ""            '清除工作表1,年度範圍
        Do
            .Range(S & 1).Offset(, Y) = 2005 + Y
            Y = Y + 1
        Loop While 2005 + Y < Year(Date)
        For i = 2 To .Range("A" & .Rows.Count).End(xlUp).Row
            v = .Cells(i, 1).Value
            GetDividend (v)
            .Cells(i, S).Resize(, Y) = Application.WorksheetFunction.Transpose(工作表2.Range("H4").Resize(Y))
            If Application.Sum(.Cells(i, S).Resize(, Y)) > 1 Then
                .Cells(i, S).Offset(, Y) = 1
            Else
                .Cells(i, S).Offset(, Y) = 0
            End If
        Next
        .Range(S & 1).CurrentRegion.Replace "--", "", xlWhole
    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")(11)
        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[/code]

wufonna 發表於 2013-9-19 21:14

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

wufonna 發表於 2014-9-1 15:56

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=58658&ptid=10453]7#[/url] [i]GBKEE[/i] [/b]
請問 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

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=70319&ptid=10453]9#[/url] [i]wufonna[/i] [/b]
要改一下[code]  Dim AR
    With 工作表1
        AR = .Range("E1:F1")
        .Range("E:F") = ""
        .Range("E1:F1") = AR
'        .Range("E2").CurrentRegion = ""            '清除工作表1,年度範圍[/code]

wufonna 發表於 2014-9-1 19:54

[i=s] 本帖最後由 wufonna 於 2014-9-1 20:00 編輯 [/i]

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=70323&ptid=10453]10#[/url] [i]GBKEE[/i] [/b]

謝謝 G 大大

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

還有下面是錯誤是什網頁錯誤嗎
謝謝

wufonna 發表於 2014-9-1 20:18

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=70326&ptid=10453]11#[/url] [i]wufonna[/i] [/b]


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

GBKEE 發表於 2014-9-2 14:34

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=70327&ptid=10453]12#[/url] [i]wufonna[/i] [/b]
11#所說的錯誤,程式碼在哪發生的.

wufonna 發表於 2014-9-2 17:22

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=70338&ptid=10453]13#[/url] [i]GBKEE[/i] [/b]

GBKEE 大大
程式沒有錯誤
可是有時資料沒捉到
像這次 勝一 沒捉到
謝謝

joey0415 發表於 2014-9-3 11:14

[i=s] 本帖最後由 joey0415 於 2014-9-3 11:19 編輯 [/i]

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=70344&ptid=10453]14#[/url] [i]wufonna[/i] [/b]

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

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

網址又清楚

yam會下載一堆沒用的東西

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

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

參考

GBKEE 發表於 2014-9-3 16:10

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=70344&ptid=10453]14#[/url] [i]wufonna[/i] [/b]
請詳看註解[code]Private Sub GetDividend(ByVal ss As String)
    Dim rr As String, T As Date, i, ii, k, j, S As Object
    '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            '等待8秒 3秒太少會誤錯改8妙
                DoEvents
                Application.SendKeys "~"                    '股票代號錯誤,網頁會有訊息,須按確定,才可繼續下面股票代號
               
                Exit Do
              End If
        Loop
        ''***不是等待8秒 3秒太少會誤錯改8妙 ***
        Do
        Set S = .Document.getElementsByTagName("table")(4) ' 新的 table 4
        Loop Until Not S Is Nothing
        '*** 勝一 沒捉到 ????
        '*** 因程式運行太快 , S Is Nothing, S 尚未指定為.Document.getElementsByTagName("table")(4)
        '*** 程式已經執行下一行, With 工作表2 的程式碼

        With 工作表2
            .UsedRange.Clear
            For i = 0 To S.Rows.Length - 1      '寫入資料
                k = k + 1
                'For j = 0 To S.Rows(i).Length - 1  '這行是錯誤的 也是多餘的迴圈
                   '用 On Error Resume Next 使程式繼續執行
                    For ii = 0 To S.Rows(i).Cells.Length - 1  ' 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
[/code]

wufonna 發表於 2014-9-3 20:52

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=70373&ptid=10453]16#[/url] [i]GBKEE[/i] [/b]


    謝謝 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

[i=s] 本帖最後由 wufonna 於 2014-9-3 21:11 編輯 [/i]

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=70365&ptid=10453]15#[/url] [i]joey0415[/i] [/b][code]Sub 巨集1()
'
' 巨集1 巨集
'

'
    With ActiveSheet.QueryTables.Add(Connection:= _
        "URL;https://djinfo.cathaysec.com.tw/Z/ZC/ZCX/ZCXNEWCATHAYSEC.DJHTM?A=2882", _
        Destination:=Range("$A$1"))
        .Name = "ZCXNEWCATHAYSEC.DJHTM?A=2882"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = xlSpecifiedTables
        .WebFormatting = xlWebFormattingNone
        .WebTables = "2,3"
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
    End With
End Sub
[/code]請教 大大 這段如何精簡程式碼
像 table 這樣
因要從中取得收盤價
謝謝 大大

joey0415 發表於 2014-9-4 08:17

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=70384&ptid=10453]18#[/url] [i]wufonna[/i] [/b]

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

wufonna 發表於 2014-9-4 10:16

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=70391&ptid=10453]19#[/url] [i]joey0415[/i] [/b]
謝謝 大大
國泰的資料真的快多了

頁: [1] 2

麻辣家族討論版版為 麻辣學園 網站成員  由 昱得資訊工作室 © Since 1993 所提供