| |
WebQuery の際、再計算手動に設定しても、「再計算」が入ってしまいます。
取得データが少ないときは１分以内で終わっていたのですが、130銘柄の取得では数十分かかってしまいます。
Application.Calculation = xlManual
を使っても再計算してしまいます。
Googleで調べても、なかなか解決につながるページを見つけることができなかったので質問をさせてください。
Sub set終値()
Dim t As Single
Dim RightEnd As Range
Dim cnt As Long
Dim y, myCode
Sheets("株価入力").Select
t = Timer
Application.ScreenUpdating = False
Application.Calculation = xlManual '再計算手動コでも40分以上 コメントアウトでも40分以上
Sheets("作業").Select
With Sheets("株価入力")
myCode = .Range("A4", .Cells(.Rows.Count, 1).End(xlUp)).Value '銘柄コードのセル群
Set RightEnd = .Cells(4, 256).End(xlToLeft) '前日終値のTopCell
y = RightEnd.Resize(UBound(myCode, 1), 1).Value '前日終値
For Each v In myCode
cnt = cnt + 1
Select Case v
Case ""
y(cnt, 1) = Empty '終値
Case Else
y(cnt, 1) = Get終値(v) '終値
End Select
Next
End With
'
RightEnd.Resize(cnt, 1).Value = y '終値
Application.Calculation = xlAutomatic '再計算自動 1.
Application.ScreenUpdating = True
Sheets("株価入力").Select
t = Timer - t
MsgBox Int(t / 60) & " 分 " & (t Mod 60) & " 秒 " & " かかりました"
End Sub
Function Get終値(code As Variant)
Dim webURL As String
Dim r As Range
webURL = "URL;ht tp://stocks.finance.yahoo.co.jp/stocks/detail/?code=" & code
'Sheets("作業").Select
With ActiveSheet.QueryTables.Add(Connection:=webURL, Destination:=Range("A1"))
.WebSelectionType = xlEntirePage '全て取り込み '削除 表のみ取り込み 2.
.WebFormatting = xlWebFormattingNone
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.Refresh BackgroundQuery:=False
End With
'
'---'終値取り込み
Set r = FindCell("詳細情報")
If r Is Nothing Then
Get終値 = Empty
Else
Get終値 = c.Offset(-1, 2).Value
End If
'
Sheets("作業").Cells.Clear
Sheets("作業").Cells.QueryTable.Delete
Set r = Nothing
End Function
Public Function FindCell(key As String) As Range
Set FindCell = Sheets("作業").Columns("A:A").Find(What:=key, LookAt:=xlPart)
End Function
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
