こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

締切り済みの質問

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

投稿日時 - 2008-07-24 23:29:06

QNo.4201932

すぐに回答ほしいです

このQ&Aは役に立ちましたか?

17人が「このQ&Aが役に立った」と投票しています

回答(4)

ANo.4

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

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

投稿日時 - 2008-07-27 20:16:07

ANo.3

追加で調べてみましたが、
>「インターネットサーバーに接続できません」と出て、きちんと実行できません。
このエラーの場合は、
>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/AcTipsVbaXMLHTTP.html

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

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

投稿日時 - 2008-07-27 17:07:26

お礼

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

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

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

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

投稿日時 - 2008-07-27 19:53:15

ANo.2

[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
として1回50件の取得ができるかどうか試してみてはいかがでしょう。
または手作業の[Webクエリ]で取得できるかどうかも試してみたほうが良いでしょう。



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

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

投稿日時 - 2008-07-25 20:32:35

お礼

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

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

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

投稿日時 - 2008-07-27 19:11:55

ANo.1

こんにちは。

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

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

投稿日時 - 2008-07-24 23:58:47

お礼

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

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

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

投稿日時 - 2008-07-27 19:08:05

あなたにオススメの質問