Board logo

標題: 上網抓股票資料 [打印本頁]
作者: chairles59    時間: 2016-3-5 01:49     標題: 上網抓股票資料

請教各位大大:
有個VBA程式資料抓不下來
請各位大大幫忙查看哪裡有問題
謝謝
Private Sub CommandButton1_Click()
Dim po As Integer        '宣告PO為整數

lR = Range("A2").End(xlDown).Row
Rows(lR + 1 & ":400").Select       'a欄空白以下全刪除
Selection.Delete shift:=xlUp


LRA = Range("C2").End(xlDown).Row
For i = 3 To LRA
If Cells(i, 5) <> "" Then
ValueSno = "$A$" & i
Linkss = "URL;https://tw.stock.yahoo.com/q/q?s=" & Cells(i, 1)
        
po = lR - 5 + (7 * (i - 2)) '定抓取資料表格迴圈
With ActiveSheet.QueryTables.Add(Connection:= _
Linkss, Destination:=Sheets("工作表1").Range("b" & po))
      .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 = "6"
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
        .Name = .ResultRange.Cells(3, 1)
    End With   
Range("A" & po + 2) = Cells(i, 1)
Cells(i, 2) = "=vlookup(" & Cells(i, 1) & ",$A$16:$0$200,2,0)"
Cells(i, 2) = Mid(Cells(i, 2), 5)
Cells(i, 7) = "=vlookup(" & Cells(i, 1) & ",$A$16:$0$200,4,0)"
End If
Next

End Sub
作者: GBKEE    時間: 2016-3-5 16:02

回復 1# chairles59

ActiveSheet =Sheets("工作表1") 是嗎?
  1. With ActiveSheet.QueryTables.Add(Connection:= _
  2. Linkss, Destination:=Sheets("工作表1").Range("b" & po))
複製代碼
修改看看
  1. With ActiveSheet.QueryTables.Add(Connection:= _
  2. Linkss, Destination:=ActiveSheet.Range("b" & po))
複製代碼
作者: chairles59    時間: 2016-3-5 20:21

回復 2# GBKEE
感謝大大抽空幫我看
但是好像也沒有辦法抓下資料
附個壓縮檔再麻煩大大幫我看一下
作者: GBKEE    時間: 2016-3-6 15:03

本帖最後由 GBKEE 於 2016-3-6 15:05 編輯

回復 3# chairles59

Rows(lR + 1 & ":400").Clear    '直接清除儲存格,不必Select再刪除
If Cells(I, 3) <> "" Then   '附檔 工作表C欄 ,沒有買進日期,所以不會執行匯入資料的程式碼
Cells(I, 2) = "=vlookup(" & Cells(I, 1) & ",$A$16:$O$200,2,0)" 是英文字母O,不是數字0
作者: chairles59    時間: 2016-3-12 00:50

版主:
不勝感謝版主不斷的幫我修改
但是我只抓下第一個股票就卡在
Cells(i, 2) = Mid(Cells(i, 2), 5)
它顯示
執行階段錯誤'13
型態不符
能否請版主在幫我看一下那裡還有問題
謝謝
作者: joey0415    時間: 2016-3-13 12:50

回復 5# chairles59
你試試
  1. Sub 價位更新()
  2.     Application.ScreenUpdating = False
  3.     Sheets(1).Activate
  4.     rc = Cells(Rows.Count, 1).End(xlUp).Row
  5.     For i = 3 To rc
  6.         Range("r1:az10").ClearContents
  7.         sn = Cells(i, 1)
  8.         With ActiveSheet.QueryTables.Add(Connection:="URL;https://tw.stock.yahoo.com/q/q?s=" & sn, Destination:=Range("$s$1"))
  9.             .WebFormatting = xlWebFormattingNone
  10.             .WebTables = "4,7"
  11.             .Refresh BackgroundQuery:=False
  12.             .Delete
  13.         End With
  14.         Range("b1") = Left(Range("w1"), 10)
  15.         Cells(i, 10) = Range("t5")
  16.         Cells(i, 9) = Range("u5")
  17.     Next
  18.     Range("r1:az10").ClearContents
  19.     Range("a1").Select
  20.     Application.ScreenUpdating = True
  21. End Sub
複製代碼
[attach]23438[/attach]
作者: c_c_lai    時間: 2016-3-14 10:07

回復 5# chairles59
茲將 GBKEE 版大給你的提示整理並稍加修正，
其實 GBKEE 版大已經指引出你的問題所在。
  1. Sub Ex()
  2.     Dim po As Integer                  '  宣告 PO 為整數
  3.    
  4.     lR = Range("A2").End(xlDown).Row      '  R = 9 : Variant/Long
  5.     Rows(lR + 1 & ":400").Clear                    '  直接清除儲存格,不必 Select 再刪除
  6.     '  Selection.Delete shift:=xlUp
  7.    
  8.     LRA = Range("B2").End(xlDown).Row  '  LRA = 9 : Variant/Long

  10.     For i = 3 To LRA
  11.         '  If Cells(i, 3) <> "" Then    ' 工作表 C 欄 ,沒有買進日期,所以不會執行匯入資料的程式碼
  12.         If Cells(i, 3) = "" Then        ' 修正為空值時始進行資料匯入
  13.             Valuesno = "$A$" & i
  14.             Linkss = "URL;https://tw.stock.yahoo.com/q/q?s=" & Cells(i, 1)
  15.         
  16.             po = lR - 5 + (7 * (i - 2)) '  定抓取資料表格迴圈

  18.             With ActiveSheet.QueryTables.Add(Connection:= _
  19.                                 Linkss, Destination:=ActiveSheet.Range("B" & po))
  20.                 .FieldNames = True
  21.                 .RowNumbers = False
  22.                 .FillAdjacentFormulas = False
  23.                 .PreserveFormatting = True
  24.                 .RefreshOnFileOpen = False
  25.                 .BackgroundQuery = True
  26.                 .RefreshStyle = xlInsertDeleteCells
  27.                 .SavePassword = False
  28.                 .SaveData = True
  29.                 .AdjustColumnWidth = True
  30.                 .RefreshPeriod = 0
  31.                 .WebSelectionType = xlSpecifiedTables
  32.                 .WebFormatting = xlWebFormattingNone
  33.                 .WebTables = "6"
  34.                 .WebPreFormattedTextToColumns = True
  35.                 .WebConsecutiveDelimitersAsOne = True
  36.                 .WebSingleBlockTextImport = False
  37.                 .WebDisableDateRecognition = False
  38.                 .WebDisableRedirections = False
  39.                 .Refresh BackgroundQuery:=False
  40.                 .Name = .ResultRange.Cells(3, 1)
  41.             End With
  42.             
  43.             Range("A" & po + 2) = Cells(i, 1)
  44.             '  Cells(i, 2) = "=vlookup(" & Cells(i, 1) & ",$A$16:$O$200,2,0)"    '  是英文字母 O,不是數字 0
  45.             Cells(i, 2) = "=vlookup(" & Cells(i, 1) & ",$A$11:$O$200,2,0)"       '  從 $A$16 起始之範圍會造成 B3 得出不正確值
  46.             Cells(i, 2) = Mid(Cells(i, 2).Text, 5)                               '  Mid(Cells(i, 2), 5) 會產生執行階段錯誤 13 型態不符
  47.             
  48.             '  Cells(i, 7) = "=vlookup(" & Cells(i, 1) & ",$A$16:$O$200,4,0)"    '  是英文字母 O,不是數字 0
  49.             Cells(i, 7) = "=vlookup(" & Cells(i, 1) & ",$A$11:$O$200,4,0)"       '  從 $A$16 起始之範圍會造成 G3 得出不正確值
  50.         End If
  51.     Next
  52. End Sub
複製代碼
作者: c_c_lai    時間: 2016-3-14 10:16

回復 5# chairles59
[attach]23445[/attach]
作者: chairles59    時間: 2016-3-17 02:23

回復 9# c_c_lai

c_c_lai大大 :
感謝出手指導
因是新手要消化需要一點時間
經過修改
現在跑起來可以了
如有還問題
請大大幫忙
謝謝各位大大



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