VBAでWebクエリにて情報を自動収集するプログラム

自動売買ロボット作成マニュアルという本を買いました。
これは株などを自動売買するプログラムを作るための方法が書いた本です。（言語はエクセルに搭載されてあるVBAというプログラム言語です）
そのプログラムを作る過程で、まずYahoo!ファイナンスから株価などの情報を10年分自動収集するプログラムを作ったのですが、「インターネットサーバーに接続できません」と出て、きちんと実行できません。
そこで、デバックをすると.Refresh BackgroundQuery:=Falseというプログラムのところがチェックされました。どうしたらいいでしょうか？

この文章だけでは対処できないと思いますのでプログラムを書いておきます。長々とお読みいただきありがとうございます。どうかお知恵をお貸しください。

Dim url As String
Dim lastrow As Integer
Dim i As Integer

Sub Get_Data()

With ActiveSheet.QueryTables.Add(Connection:=url, Destination:=Cells(lastrow, 2))
.Name = _
"t?s=998407.o&a=4&b=22&c=2008&d=7&e=24&f=2008&g=d&q=t&y=0&z=998407.o&x=_1"
.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 = "19"
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With

End Sub

Sub Calc()

Dim code As String
Dim data_length As Integer, date_temp As Date
Dim day_s As Integer, month_s As Integer, year_s As Integer
Dim day_e As Integer, month_e As Integer, year_e As Integer
Dim row_length As Integer
code = "998407.o"
data_length = -3650

date_temp = DateAdd("d", data_length, Now)

day_e = Day(Now)
month_e = Month(Now)
year_e = Year(Now)
day_s = Day(date_temp)
month_s = Month(date_temp)
year_s = Year(date_temp)

Range("B4:H65000").ClearContents

For i = 0 To Abs(data_length) * 0.65 Step 50
url = "URL; http://table.yahoo.co.jp/t?s=" & code & "&a=" & month_s & "&b=" & day_s & "&c=" & year_s & "&d=" & month_e & "&e=" & day_e & "&f=" & year_e & "&g=d&q=t&y=" & i & "&z=" & code & "&x=.csv"
If i = 0 Then
lastrow = "4"
Call Get_Data

If Range("B4") = "" Then
Exit Sub
End If

Else
lastrow = (Range("B4").End(xlDown).Row + 1)
Call Get_Data
Range("B" & lastrow, "H" & lastrow).Delete
row_length = (Range("B4").End(xlDown).Row)
If row_length - lastrow < 49 Then
Exit For
End If
End If
Next

Range("B5:H65000").Sort Key1:=Columns("B")

lastrow = Range("B4").End(xlDown).Row
Range("B5", "B" & lastrow).NumberFormatLocal = "yyyy/mm/dd"

Range("C5", "H" & lastrow).NumberFormatLocal = "0"
Range("A1").Select

End Sub

No.4 回答者： end-u 回答日時： 2008/07/27 20:16

>実行時エラー'1004':

>ファイルにアクセスできませんでした。次のいずれかを行ってみてください。
>？指定したフォルダがあることを確認します。
>？ファイルを含むフォルダが読み取り専用になっていないことを確認します。
>？指定したファイルの名前に次のいずれかの文字も含まれていないことを確認します：<>?[]:|*
>？ファイル名およびパス名が半角で218文字より長くないことを確認します。
>
>と出ました。どうしたらいいでしょうか？

それは既に#2にてアドバイスしてます。
>原因は下記ページに書かれている事のようです。
>http://www2s.biglobe.ne.jp/~iryo/kabu/siryou/hon …
対処方法も#3に既に書いてます。
キャッシュ削除で対応しない限り、ie7でのwebクエリ連続実行はあきらめたほうが良いでしょう。

No.3 回答者： end-u 回答日時： 2008/07/27 17:07

追加で調べてみましたが、

>「インターネットサーバーに接続できません」と出て、きちんと実行できません。
このエラーの場合は、
>url = "URL; http...
この箇所の"URL;"と"http..."の間に半角スペースがあるからでしょう。
xl2000/ie6 と xl2003/ie6 の環境では動作しますが xl2007/ie7 では同様のエラーになります。
url = "URL;http...
とすれば、xl2007/ie6 の環境であれば動作するような気がしますね。



ie7の場合は前述したように、webクエリでの連続取得は難しいと思います。
Loop中に適宜、キャッシュを削除すれば可能かもしれません。
http://support.microsoft.com/kb/262110/ja
（実際には試してないのでなんとも）

代替手段としては、webクエリを使わずに[XMLHTTP オブジェクト]を使う方法があります。
http://www.f3.dion.ne.jp/~element/msaccess/AcTip …

ちょっと試作してみました。応用ができるようであれば工夫してみてください。
難しいようなら捨て置いて頂いて構いません。

Sub try()
　　'個別銘柄の場合は CX = 7
　　Const FLD As String _
　　　　　= "日付 始値 高値 安値 終値 出来高 調整後終値*" '列項目名
　　Const COD As String = "998407"　　 '銘柄CODE
　　Const CX　As Long = 5　　　　　　　'配列の列数（項目数）
　　Const YY　As Long = 10　　　　　　 '期間年数
　　Const PTN As String = ">([^<>]+)<" 'データ抜き出しパターン
　　Dim D_LEN As Long　　'期間日数
　　Dim D_CHK As Date　　'開始期間Date
　　Dim D_TMP As Date　　'検索開始Date
　　Dim xh　　As Object　'MSXML2.XMLHTTP
　　Dim re　　As Object　'VBScript.RegExp
　　Dim mc　　As Object　'RegExp.Match
　　Dim url　 As String　'URLアドレス
　　Dim chk　 As String　'テーブル判断項目htmlTEXT
　　Dim ret　 As String　'XMLHTTP.responsetext
　　Dim s(7)　As String　'URL構成文字列
　　Dim flg　 As Boolean 'LoopOut判定FLG
　　Dim n　　 As Long　　'chk文字存在判定
　　Dim x　　 As Long　　'HTML項目Loop用
　　Dim cnt　 As Long　　'データCOUNT
　　Dim i　　 As Long
　　Dim j　　 As Long
　　Dim k　　 As Long
　　Dim v, w　　　　　　 'データ格納用配列,列項目名分割用配列
　　
　　On Error Resume Next
　　Set xh = CreateObject("MSXML2.XMLHTTP")
　　On Error GoTo 0
　　If xh Is Nothing Then Exit Sub
　　
　　D_CHK = DateAdd("yyyy", -YY, Date)
　　D_CHK = DateAdd("d", -1, D_CHK)
　　D_LEN = CLng(Date - D_CHK) + 1
　　D_TMP = DateAdd("d", -50, D_CHK)
　　s(0) = "http://table.yahoo.co.jp/t?s=" & COD
　　s(1) = "c=" & Year(D_TMP)　'開始年
　　s(2) = "a=" & Month(D_TMP) '開始月
　　s(3) = "b=" & Day(D_TMP)　 '開始日
　　s(4) = "f=" & Year(Date)　 '現在年
　　s(5) = "d=" & Month(Date)　'現在月
　　s(6) = "e=" & Day(Date)　　'現在日
　　s(7) = "g=d&q=t&y="
　　url = Join(s, "&")
　　'Debug.Print url
　　
　　ReDim v(0 To D_LEN, 1 To CX)
　　w = Split(FLD)
　　For i = 1 To CX
　　　　v(0, i) = w(i - 1)
　　Next
　　chk = "<small>" & v(0, CX) & "</small></th></tr>"
　　
　　Set re = CreateObject("VBScript.RegExp")
　　re.Pattern = PTN
　　re.Global = True
　　
　　With Sheets.Add 'ActiveSheet
　　　　cnt = 1
　　　　For i = 0 To D_LEN Step 50
　　　　　　xh.Open "GET", url & i, False
　　　　　　xh.Send
　　　　　　If (xh.Status >= 200) And (xh.Status < 300) Then
　　　　　　　　ret = xh.responsetext
　　　　　　　　n = InStr(ret, chk)
　　　　　　　　If n = 0 Then Exit For
　　　　　　　　ret = Mid$(ret, n + Len(chk))
　　　　　　　　Set mc = re.Execute(ret)
　　　　　　　　x = 0
　　　　　　　　For j = 1 + i To 50 + i
　　　　　　　　　　cnt = j
　　　　　　　　　　For k = 1 To CX
　　　　　　　　　　　　v(j, k) = mc(x).submatches(0)
　　　　　　　　　　　　'データ終了判定
　　　　　　　　　　　　If k = 1 Then
　　　　　　　　　　　　　　flg = IsDate(v(j, 1))
　　　　　　　　　　　　　　If flg Then
　　　　　　　　　　　　　　　　flg = (CDate(v(j, 1)) >= D_CHK)
　　　　　　　　　　　　　　End If
　　　　　　　　　　　　　　If Not flg Then
　　　　　　　　　　　　　　　　j = i + 50
　　　　　　　　　　　　　　　　i = D_LEN
　　　　　　　　　　　　　　　　Exit For
　　　　　　　　　　　　　　End If
　　　　　　　　　　　　End If
　　　　　　　　　　　　x = x + 1
　　　　　　　　　　Next
　　　　　　　　Next
　　　　　　End If
　　　　Next
　　　　'Debug.Print cnt
　　　　.Range("A1").Resize(cnt, CX).Value = v
　　End With

　　Set mc = Nothing
　　Set re = Nothing
　　Set xh = Nothing
End Sub

この回答へのお礼

わざわざ考えていただき本当にありがとうございました。

URLのところを変更したところ、IE7、Excel2007でも途中まで実行できました。私にとっては大きな一歩です。
でも、完璧なデータを取得はできませんでした。何年分かのデータを取得したところで、

実行時エラー'1004':
ファイルにアクセスできませんでした。次のいずれかを行ってみてください。
？指定したフォルダがあることを確認します。
？ファイルを含むフォルダが読み取り専用になっていないことを確認します。
？指定したファイルの名前に次のいずれかの文字も含まれていないことを確認します：<>?[]:|*
？ファイル名およびパス名が半角で218文字より長くないことを確認します。

と出ました。どうしたらいいでしょうか？
VBAについては基本的なことしかわかりませんので、もう少し勉強してからend-uさんの提案した方法を試してみたいと思います。

お礼日時：2008/07/27 19:53

No.2 回答者： end-u 回答日時： 2008/07/25 20:32

[win2000/excel2000/ie6]の環境で試したところ、正常に取得できます。

#ただし、2000では『.WebDisableRedirections = False』の行を削除。
#[WebDisableRedirectionsプロパティ]は2002で追加されたため。

ですので環境によります。
『Internet Explorer 7』を利用されていない場合は、新規Bookでテスト的に
>For i = 0 To Abs(DATA_LENGTH) * 0.65 Step 50
この行を
For i = 0 To 0 'Abs(DATA_LENGTH) * 0.65 Step 50
として１回50件の取得ができるかどうか試してみてはいかがでしょう。
または手作業の[Webクエリ]で取得できるかどうかも試してみたほうが良いでしょう。



『Internet Explorer 7』を利用されている場合は、
http://www.panrolling.com/books/gr/gr45.html
このページの最後、『Internet Explorer 7を利用されている方へ』を見てください。

原因は下記ページに書かれている事のようです。
http://www2s.biglobe.ne.jp/~iryo/kabu/siryou/hon …

この回答へのお礼

私のPCはIE7、Excel2007だから正常に取得できなかったのですね。

家にあるもう一つのパソコン（Windows2000）で、試したところちゃんと取得することができました。

どうも回答ありがとうございました。

お礼日時：2008/07/27 19:11

No.1 回答者： iriyak 回答日時： 2008/07/24 23:58

こんにちは。

著者のサイトで読者報告で誤り訂正が掲載されていました。急ぎならば、著者に直接コンタクトを取り解決支援を依頼する手段も並行してとられるのがよいのでは??

http://www.panrolling.com/blog/morita.html

この回答へのお礼

回答ありがとうございます。

サイトを参考にさせていただきます。

もう少し、試行錯誤してみようかと思います。

お礼日時：2008/07/27 19:08