| |
>だいたいのコードは把握してます。まずマクロの冒頭に
>
>要するに、クエリーの更新を止めることで負荷を減らし、取得したデータは即座に
>値のみに変えてしまえば良いのではないか ? という発想なのです。
>テストしてみて下さい。
ご助言ありがとうございます。
さっそく試してみましたが、結果は同じでした(泣)。
一部省略しましたが、変更したコードは下記のような感じです。
追加場所が間違っている、または問題ありそうなコードがあるでしょうか？
ご指摘があれば、よろしくお願い致します。
'-----------------------------------------------------------------------------------
' 全ての株価を取得
'-----------------------------------------------------------------------------------
Public Sub LoadAllKabuka()
'@@@@@@@@@@@@@@@@@@@@@@@@@@ Keinさん指示で追加
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
For m = MIN_CODE To MAX_CODE Step BLOCK 'MIN_CODE = 1000, MAX_CODE = 9999, BLOCK = 50
'URLデータの作成
code_no = m
strData = "URL;http://quote.yahoo.co.jp/q?s="
For i = 0 To BLOCK - 2
strData = strData + CStr(code_no) + "+"
code_no = code_no + 1
Next
strData = strData + CStr(code_no)
Call GetWebQuery(strData, strRow, 13) 'Webデータ取得
Application.CutCopyMode = False '@@@@@@@@@@@@@@@@@@@@@@@@@@ Keinさん指示で追加
'>>>>>>>>>>>>>>>>>>>>>>>>>>>
'取得データの加工処理
'>>>>>>>>>>>>>>>>>>>>>>>>>>>
ModKabu.LabNow.Caption = StrNow + " Step3"
DoEvents
Next
'@@@@@@@@@@@@@@@@@@@@@@@@@@ Keinさん指示で追加
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub
'-----------------------------------------------------------------------------------
' 50銘柄分のデータを取得
'-----------------------------------------------------------------------------------
Private Sub GetWebQuery(strUrl$, strRange$, figs%)
Dim strName$
Dim chk&
Dim strFigs$
strFigs = CStr(figs)
strName = Match("/\/([^\/]+$)/", strUrl)
StrNow = "進行状況 = " + Mid(strName, 5, 4)
ModKabu.LabNow.Caption = StrNow + " Step1"
DoEvents '進行状況更新用(Windowsに一旦制御を渡す)
With ActiveSheet.QueryTables.Add(Connection:=strUrl, Destination:=Range(strRange))
.Name = strName
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = False
.RefreshStyle = xlOverwriteCells '上書きモード
.SavePassword = False
.SaveData = False
.AdjustColumnWidth = True
'.RefreshPeriod = 0 '@@@@@@@@@@@@@@@@@@@@@@@@@@ Keinさん指示で削除
.EnableRefresh = False '@@@@@@@@@@@@@@@@@@@@@@@@@@ Keinさん指示で追加
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingNone
.WebTables = strFigs
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.Refresh BackgroundQuery:=False
'@@@@@@@@@@@@@@@@@@@@@@@@@@ Keinさん指示で追加
With .ResultRange
.Copy
.PasteSpecial xlPasteValues
End With
End With
chk = ActiveSheet.QueryTables.Count
ActiveSheet.QueryTables(chk).Delete
ModKabu.LabNow.Caption = StrNow + " Step2"
DoEvents
End Sub
|
|
おさる
- 05/12/28(水) 14:39 -
