Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


8423 / 13646 ツリー ←次へ | 前へ→

【32967】WEBクエリ取得中のまま固まってしまう おさる 05/12/28(水) 12:03 質問[未読]
【32970】Re:WEBクエリ取得中のまま固まってしまう かみちゃん 05/12/28(水) 12:14 発言[未読]
【32975】Re:WEBクエリ取得中のまま固まってしまう おさる 05/12/28(水) 12:57 お礼[未読]
【32976】Re:WEBクエリ取得中のまま固まってしまう かみちゃん 05/12/28(水) 13:14 発言[未読]
【32977】Re:WEBクエリ取得中のまま固まってしまう おさる 05/12/28(水) 13:22 お礼[未読]
【32989】Re:WEBクエリ取得中のまま固まってしまう かみちゃん 05/12/28(水) 15:36 回答[未読]
【32998】Re:WEBクエリ取得中のまま固まってしまう おさる 05/12/28(水) 16:25 お礼[未読]
【33000】Re:WEBクエリ取得中のまま固まってしまう かみちゃん 05/12/28(水) 16:34 発言[未読]
【33001】Re:WEBクエリ取得中のまま固まってしまう おさる 05/12/28(水) 16:44 お礼[未読]
【33006】Re:WEBクエリ取得中のまま固まってしまう かみちゃん 05/12/28(水) 23:45 回答[未読]
【33030】Re:WEBクエリ取得中のまま固まってしまう おさる 05/12/29(木) 12:08 お礼[未読]
【33044】Re:WEBクエリ取得中のまま固まってしまう かみちゃん 05/12/29(木) 21:45 発言[未読]
【33394】Re:WEBクエリ取得中のまま固まってしまう おさる 06/1/10(火) 15:28 お礼[未読]
【32978】Re:WEBクエリ取得中のまま固まってしまう Kein 05/12/28(水) 13:29 回答[未読]
【32983】Re:WEBクエリ取得中のまま固まってしまう おさる 05/12/28(水) 14:39 お礼[未読]
【32999】Re:WEBクエリ取得中のまま固まってしまう おさる 05/12/28(水) 16:33 お礼[未読]

【32967】WEBクエリ取得中のまま固まってしまう
質問  おさる  - 05/12/28(水) 12:03 -

引用なし
パスワード
   始めまして。おさると申します。
株価データを取得したく、WEBクエリ利用したコードを作成しましたが、WEBクエリの取得中に処理が戻らなくなってしまい、どうしていいものか困っています。WEBクエリ取得部分は下記のようなコードになっており、strUrl、strRange、strFigsは文字列変数を使用しています。基本的には動作しているので、WEBクエリ取得のコードが悪いのではないと思っています。推測ではサーバーからの反応がかなり遅い(返ってこない?)時に死ぬようです。この場合、「Ctrl+Break」でも停止できず、APIのSetTimer()を使用してCancelRefreshを実行使用としましたが、この状況時にはコールバック関数も呼ばれないようで、にっちもさっちも行きません。WEBクエリの取得に伴い、最初からタイムアウトを設定する方法、もしくはこのような現象を回避する方法が分かる方がいましたら、ご教授していただけないでしょうか?

  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
    .WebSelectionType = xlSpecifiedTables
    .WebFormatting = xlWebFormattingNone
    .WebTables = strFigs
    .WebPreFormattedTextToColumns = True
    .WebConsecutiveDelimitersAsOne = True
    .WebSingleBlockTextImport = False
    .WebDisableDateRecognition = False
    .Refresh BackgroundQuery:=False
    

  End With

どうかよろしくお願い致します。

【32970】Re:WEBクエリ取得中のまま固まってしまう
発言  かみちゃん E-MAIL  - 05/12/28(水) 12:14 -

引用なし
パスワード
   こんにちは。かみちゃん です。

>株価データを取得したく、WEBクエリ利用したコードを作成しましたが、WEBクエリの取得中に処理が戻らなくなってしまい、どうしていいものか困っています。

同様のことをしていますが、固まったことはありません。
コード全体、どこのサイトをご利用かわからないので、なんとも言えませんが・・・

【32975】Re:WEBクエリ取得中のまま固まってしまう
お礼  おさる  - 05/12/28(水) 12:57 -

引用なし
パスワード
   >>株価データを取得したく、WEBクエリ利用したコードを作成しましたが、WEBクエリの取得中に処理が戻らなくなってしまい、どうしていいものか困っています。
>
>同様のことをしていますが、固まったことはありません。
>コード全体、どこのサイトをご利用かわからないので、なんとも言えませんが・・・

情報ありがとうございます。株価データの取得はYahooファイナインスを使用しています。コードを全部書くのは厳しいのですが、大まかな流れとしては、Yahooファイナインスのマーケット速報から50銘柄分毎のデータを下記のような方法でURLとして指定し、これを1000〜9999銘柄分(180回)のデータ取得しようとしています。

  "http://quote.yahoo.co.jp/q?s=1000+1001+1002+1003+...省略...+1049"

当然、株価コードが存在しないものもありますので、50銘柄分(1回のWEBクエリ取得)毎に不要なデータは削除しています。この方法でWEBクエリの取得を実行していると、不特定回数目でWEBクエリ取得から処理が返ってこなくなります(ExelのステータスバーもWEB接続中表示のまま)。特定回数で固まってしまうのであれば、URLや指定の表番号に問題が有る等が考えられますが、不特定の為、原因がわかりません。ブラウザなどでも、なかなか表示されずに、挙句「サーバーが見つかりません」などが表示され、更新を実行するとあっさり表示されるようなときがありますが(Yahooファイナインスに限らず)、そのような状況に近いようです。ただVBAのQueryTables.Add()ではサーバーからの返答がないと、みずからタイムアウトをしないのか(私が設定を知らないだけかもしれませんが)、そのまま固まってしまうように見受けられます。
サイトは関係ないように思えますが、かみちゃんさん、もし差し支えなければ、何処のサイトを利用しているか教えていただけませんか?

【32976】Re:WEBクエリ取得中のまま固まってしまう
発言  かみちゃん E-MAIL  - 05/12/28(水) 13:14 -

引用なし
パスワード
   こんにちは。かみちゃん です。

>情報ありがとうございます。株価データの取得はYahooファイナインスを使用しています。コードを全部書くのは厳しいのですが、大まかな流れとしては、Yahooファイナインスのマーケット速報から50銘柄分毎のデータを下記のような方法でURLとして指定し、これを1000〜9999銘柄分(180回)のデータ取得しようとしています。

私も
Yahoo!ファイナンス
http://quote.yahoo.co.jp/
から株価情報を600銘柄取得していますが、特に問題はおきていません。
今使っているコードは、かなり作りこんでしまっているので、のちほど、株価取得
の部分のコードだけ切り出して提示してみましょうか?

【32977】Re:WEBクエリ取得中のまま固まってしまう
お礼  おさる  - 05/12/28(水) 13:22 -

引用なし
パスワード
   >私も
>Yahoo!ファイナンス
>http://quote.yahoo.co.jp/
>から株価情報を600銘柄取得していますが、特に問題はおきていません。
>今使っているコードは、かなり作りこんでしまっているので、のちほど、株価取得
>の部分のコードだけ切り出して提示してみましょうか?

是非、お願い致しますm(_ _)m

【32978】Re:WEBクエリ取得中のまま固まってしまう
回答  Kein  - 05/12/28(水) 13:29 -

引用なし
パスワード
   だいたいのコードは把握してます。まずマクロの冒頭に

With Application
  .ScreenUpdating = False
  .DisplayAlerts = False
End With

と追加して下さい。そして

With ActiveSheet.QueryTables.Add(〜)

の下に、色々なプロパティの設定が記述してあると思いますが、もし
RefreshPeriod プロパティへ、数値を渡しているコードがあったら削除します。
そして新たに

.EnableRefresh = False

を追加します。そしてその With 構文の最後に

  With .ResultRange
   .Copy
   .PasteSpecial xlPasteValues
  End With
End With

と追加し、続けてループ構文の Next の直前に

Application.CutCopyMode = False

さらにマクロの最後に

With Application
  .ScreenUpdating = True
  .DisplayAlerts = True
End With
 
を入れて下さい。
要するに、クエリーの更新を止めることで負荷を減らし、取得したデータは即座に
値のみに変えてしまえば良いのではないか ? という発想なのです。
テストしてみて下さい。

【32983】Re:WEBクエリ取得中のまま固まってしまう
お礼  おさる  - 05/12/28(水) 14:39 -

引用なし
パスワード
   >だいたいのコードは把握してます。まずマクロの冒頭に
>
>要するに、クエリーの更新を止めることで負荷を減らし、取得したデータは即座に
>値のみに変えてしまえば良いのではないか ? という発想なのです。
>テストしてみて下さい。

ご助言ありがとうございます。
さっそく試してみましたが、結果は同じでした(泣)。
一部省略しましたが、変更したコードは下記のような感じです。
追加場所が間違っている、または問題ありそうなコードがあるでしょうか?
ご指摘があれば、よろしくお願い致します。


'-----------------------------------------------------------------------------------
'    全ての株価を取得
'-----------------------------------------------------------------------------------
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

【32989】Re:WEBクエリ取得中のまま固まってしまう
回答  かみちゃん E-MAIL  - 05/12/28(水) 15:36 -

引用なし
パスワード
   こんにちは。かみちゃん です。

>>私も
>>Yahoo!ファイナンス
>>http://quote.yahoo.co.jp/
>>から株価情報を600銘柄取得していますが、特に問題はおきていません。
>>今使っているコードは、かなり作りこんでしまっているので、のちほど、株価取得
>>の部分のコードだけ切り出して提示してみましょうか?
>
>是非、お願い致しますm(_ _)m

すでにKeinさんからコメントがついていて、解決の方向に向かわれているかもしれ
ませんが、私が使っているコードでサンプルを作ってみました。
Sheet3のA列に取得したい銘柄コードを記述します。
Sheet2にWebクエリの結果を取得して、Sheet1にその情報に基づきデータベースを
出力します。
実は、このコードは、とある掲示板で元々Keinさんから教えていただいたものに、
私なりに必要なコードを追加しています。

Sheet3の取得対象銘柄コードには、1001〜9999と連番で9000個のコードを設定して
Sheet1には、取得できた銘柄コード3888個のデータを取得するのに、約4分かかり
ましたが、特段のトラブルなく問題なく完了しました。

Sub Macro1()
 Dim Sh1 As Worksheet, Sh2 As Worksheet, Sh3 As Worksheet
 Dim C As Range, FR2 As Range
 Dim ii As Long
 Dim market As String, strCode As String
 
 'Dt010 取引値 9/15 226
 'Dt030 前日比 -8 (-3.42%)
 'Dt031 前日比 -8 (-3.42%)
 'Dt040 前日終値 234
 'Dt050 出来高 26,927,000
 'Dt060 時価総額 25,543百万円
 Dim Dt010 As Currency, Dt030 As Currency, Dt031 As Double, Dt040 As Currency, Dt050 As Currency, Dt060 As Currency
 'Dt110 始値 224
 'Dt120 高値 231
 'Dt130 安値 214
 'Dt140 売気配 ---
 'Dt150 買気配 ---
 'Dt160 発行済株式数 113,023,000株
 Dim Dt110 As Currency, Dt120 As Currency, Dt130 As Currency, Dt140 As Currency, Dt150 As Currency, Dt160 As Currency
 'Dt210 配当利回り 0.0044
 'Dt220 1株配当 1.00円
 'Dt230 株価収益率 (連) 11.44倍
 'Dt240 1株利益 (連) 19.76円
 'Dt250 純資産倍率 (連) 1.26倍
 'Dt260 1株株主資本 (連) 179.51円
 Dim Dt210 As Double, Dt220 As Currency, Dt230 As Double, Dt240 As Currency, Dt250 As Double, Dt260 As Currency
 'Dt310 株主資本比率 (連) 3.0%
 'Dt320 株主資本利益率 (連) 11.86%
 'Dt330 総資産利益率 (連) 0.33%
 'Dt340 調整1株益 (連) 19.75円
 'Dt350 決算年月 2005年3月
 'Dt360 単元株数 1,000株
 'Dt350 決算年月が"---"表示の場合があるため、Date型ではなくString型で宣言する
 Dim Dt310 As Double, Dt320 As Double, Dt330 As Double, Dt340 As Currency, Dt350 As String, Dt360 As Currency
 
 Dim St As String, MyURL As String, Ad As String
 Dim TgS As String, CpN As String
 Dim StartRow As Long, InputRow As Long
 Dim TgN As String
 Dim Dt6 As String
 Const URL As String = "http://quote.yahoo.co.jp/q?s="
 '処理時間を計測する。
 Dim StartTime As Date
 
 '処理時間を計測する。
 StartTime = Now()
 
 With Application
  .ScreenUpdating = False
  .DisplayAlerts = False
 End With
 
 Set Sh1 = Worksheets("Sheet1") '取得結果出力シート
 Set Sh2 = Worksheets("Sheet2") 'Webクエリ作業シート
 Set Sh3 = Worksheets("Sheet3") '抽出銘柄コード一覧設定シート
 If IsEmpty(Sh3.Range("A2").Value) Then GoTo ELine
 Application.StatusBar = False
 
 ii = 2
 StartRow = ii
 If Sh1.Range("S65536").End(xlUp).Row = StartRow Then
  With Sh1.Range("A2", Sh1.Range("S65536").End(xlUp))
   .ClearContents
   .NumberFormatLocal = "G/標準"
  End With
 End If
 
 Sh1.Range("A1").Resize(, 19) = Array("銘柄コード", "銘柄名", "市場", "始値", "高値", "安値", "終値", "出来高", "発行済株式数", "1株利益", "1株配当", "株価収益率", "純資産倍率", "1株株主資本", "株主資本比率", "株主資本利益率", "総資産利益率", "決算年月", "単元株数")
 Do Until Sh3.Cells(StartRow, "A").Value = ""
  InputRow = 1
  St = ""
  '50銘柄単位ずつ処理する
  Do Until InputRow > 50 Or Sh3.Cells(StartRow - 1 + InputRow, "A").Value = ""
   If IsNumeric(Sh3.Cells(StartRow - 1 + InputRow, "A").Value) And Len(Sh3.Cells(StartRow - 1 + InputRow, "A").Value) = 4 Then
    St = St & Sh3.Cells(StartRow - 1 + InputRow, "A").Value & "+"
    InputRow = InputRow + 1
   End If
  Loop
  StartRow = StartRow + InputRow - 1
 
  If St = "" Then GoTo ELine
  St = Left$(St, Len(St) - 1)
  MyURL = "URL;" & URL & St & "&d=t"
  With Application
   .ScreenUpdating = False
   .DisplayAlerts = False
  End With
  Sh2.Cells.Clear
  With Sh2.QueryTables.Add(MyURL, Sh2.Range("A1"))
   .Name = St
   .PreserveFormatting = True
   .BackgroundQuery = True
   .RefreshStyle = xlInsertDeleteCells
   .SaveData = True
   '--- Keinさんより ここから
   '.RefreshPeriod = 0
   '--- Keinさんより ここまで
   .WebSelectionType = xlAllTables
   .WebFormatting = xlWebFormattingNone
   .WebPreFormattedTextToColumns = True
   .WebConsecutiveDelimitersAsOne = True
   .WebSingleBlockTextImport = False
   .WebDisableDateRecognition = False
   .Refresh BackgroundQuery:=False
   '--- Keinさんより ここから
   .EnableRefresh = False
   With .ResultRange
    .Copy
    .PasteSpecial xlPasteValues
   End With
   '--- Keinさんより ここまで
  End With
  Set FR2 = Sh2.Range("A:A").Find("取引値", , xlValues, , , xlPrevious)
  If Not FR2 Is Nothing Then
   Ad = FR2.Address
   Do
    Set FR2 = Sh2.Range("A:A").FindNext(FR2)
    TgN = Trim(FR2.Offset(-1).Value)
    '銘柄名に「(株)」という文字があった場合の対応
    If InStr(TgN, "(株)") <> 0 Then
     If InStr(TgN, "(株)") = 1 Then
      CpN = Left$(TgN, InStr(4, TgN, "(") - 1)
     Else
      CpN = Left$(TgN, InStr(1, TgN, ")"))
     End If
    Else
     CpN = Left$(TgN, InStr(1, TgN, "(") - 1)
    End If
    '市場名を取得
    market = Mid(FR2.Offset(-1), 1, InStr(FR2.Offset(-1), ":") - 1)
    If InStrRev(market, "(") <> 0 Then
     market = Mid(market, InStrRev(market, "(") + 1)
    End If
    strCode = Mid(FR2.Offset(-1), InStr(FR2.Offset(-1), ":") + 1)
    If InStrRev(strCode, ")") <> 0 Then
     strCode = Mid(strCode, 1, InStrRev(strCode, ")") - 1)
    End If
    '取引値(終値)
    Dt010 = Val(Replace(Split(FR2.Offset(1).Value, " ")(1), ",", ""))
    '前日比
    Dt030 = Val(Replace(Split(FR2.Offset(1, 2).Value, " ")(0), ",", ""))
    Dt031 = Val(Replace(Replace(Replace(Split(FR2.Offset(1).Value, " ")(1), "(", ""), "%)", ""), ",", "")) / 100
    '前日終値
    Dt040 = Val(Replace(FR2.Offset(1, 3).Value, ",", ""))
    '出来高
    Dt050 = Val(Replace(FR2.Offset(1, 4).Value, ",", ""))
    '時価総額
    Dt060 = Val(Replace(FR2.Offset(1, 5).Value, ",", ""))
    '始値
    Dt110 = Val(Replace(FR2.Offset(3).Value, ",", ""))
    '高値
    Dt120 = Val(Replace(FR2.Offset(3, 1).Value, ",", ""))
    '安値
    Dt130 = Val(Replace(FR2.Offset(3, 2).Value, ",", ""))
    '売気配
    Dt140 = Val(Replace(FR2.Offset(3, 3).Value, ",", ""))
    '買気配
    Dt150 = Val(Replace(FR2.Offset(3, 4).Value, ",", ""))
    '発行済株式数
    Dt160 = Val(Replace(FR2.Offset(3, 5).Value, ",", ""))
    '配当利回り
    Dt210 = Val(Replace(FR2.Offset(5).Value, ",", ""))
    '1株配当
    Dt220 = Val(Replace(FR2.Offset(5, 1).Value, ",", ""))
    '株価収益率
    Dt230 = Val(Replace(Split(FR2.Offset(5, 2).Value, " ")(UBound(Split(FR2.Offset(5, 2).Value, " "))), ",", ""))
    '1株利益
    Dt240 = Val(Replace(Split(FR2.Offset(5, 3).Value, " ")(UBound(Split(FR2.Offset(5, 3).Value, " "))), ",", ""))
    '純資産倍率
    Dt250 = Val(Replace(Split(FR2.Offset(5, 4).Value, " ")(UBound(Split(FR2.Offset(5, 4).Value, " "))), ",", ""))
    '1株株主資本
    Dt260 = Val(Replace(Split(FR2.Offset(5, 5).Value, " ")(UBound(Split(FR2.Offset(5, 5).Value, " "))), ",", ""))
    '株主資本比率
    Dt310 = Val(Replace(Replace(Split(FR2.Offset(7).Value, " ")(UBound(Split(FR2.Offset(7).Value, " "))), ",", ""), "%", "")) / 100
    '株主資本利益率
    Dt320 = Val(Replace(Replace(Split(FR2.Offset(7, 1).Value, " ")(UBound(Split(FR2.Offset(7, 1).Value, " "))), ",", ""), "%", "")) / 100
    '総資産利益率
    Dt330 = Val(Replace(Replace(Split(FR2.Offset(7, 2).Value, " ")(UBound(Split(FR2.Offset(7, 2).Value, " "))), ",", ""), "%", "")) / 100
    '調整1株益
    Dt340 = Val(Replace(Replace(Split(FR2.Offset(7, 3).Value, " ")(UBound(Split(FR2.Offset(7, 3).Value, " "))), ",", ""), "%", ""))
    '決算年月
    If IsDate(FR2.Offset(7, 4).Value) Then
     Dt350 = Format(FR2.Offset(7, 4).Value, "yyyy年mm月")
    Else
     Dt350 = ""
    End If
    '単元株数
    Dt360 = Val(Replace(FR2.Offset(7, 5).Value, ",", ""))
    'セルに出力する。
    '始値  高値  安値  終値  出来高 発行済株式数 1株利益 1株配当 株価収益率 純資産倍率 1株株主資本 株主資本比率 株主資本利益率 総資産利益率 決算年月 単元株数
    'Dt110 Dt120 Dt130 Dt010 Dt050  Dt160     Dt240  Dt220  Dt230    Dt250    Dt260    Dt310     Dt320      Dt330     Dt350   Dt360
    Sh1.Cells(ii, 1).Resize(, 19).Value = _
     Array(strCode, CpN, market, Dt110, Dt120, Dt130, Dt010, Dt050, Dt160, Dt240, Dt220, Dt230, Dt250, Dt260, Dt310, Dt320, Dt330, Dt350, Dt360)
    ii = ii + 1
   Loop Until FR2.Address = Ad
   '作業用シートの値をクリアする。
   Sh2.Cells.Clear
  Else
  End If
 Loop
 Set FR2 = Nothing: Sh1.Activate
  
 '抽出したデータのセルの書式設定
 Range("A3", Range("S65536").End(xlUp)).NumberFormatLocal = "G/標準"
 Range("R3", Range("R65536").End(xlUp)).NumberFormatLocal = "yyyy""年""m""月"";@"
 
 '存在しない銘柄があった場合は、コピーするとずれるのでやめる
 'Sh1.Range("H6", Sh1.Range("H65536").End(xlUp)).Copy Sh1.Range("M6")
 With Application
   .ScreenUpdating = True
   .DisplayAlerts = True
 End With
 '処理時間を表示する。 2005.10.02 UpDate by kamicha1
 MsgBox "株価情報取得処理を終了しました" & vbCrLf & _
     " 処理時間:" & Format(Now() - StartTime, "hh:mm:ss")
ELine:
 Set Sh1 = Nothing: Set Sh2 = Nothing: Set Sh3 = Nothing
End Sub

【32998】Re:WEBクエリ取得中のまま固まってしまう
お礼  おさる  - 05/12/28(水) 16:25 -

引用なし
パスワード
   >すでにKeinさんからコメントがついていて、解決の方向に向かわれているかもしれ
>ませんが、私が使っているコードでサンプルを作ってみました。
>Sheet3のA列に取得したい銘柄コードを記述します。
>Sheet2にWebクエリの結果を取得して、Sheet1にその情報に基づきデータベースを
>出力します。
>実は、このコードは、とある掲示板で元々Keinさんから教えていただいたものに、
>私なりに必要なコードを追加しています。
>
>Sheet3の取得対象銘柄コードには、1001〜9999と連番で9000個のコードを設定して
>Sheet1には、取得できた銘柄コード3888個のデータを取得するのに、約4分かかり
>ましたが、特段のトラブルなく問題なく完了しました。
>

かみちゃんさん、わざわざ動作確認までして頂きありがとうございます。

早速確認してみましたが、結果は私のコードと同じようにある程度まで正常に動作していましたが、途中で「Web接続中・・・」表示のまま固まってしまいました。かみちゃんさんの環境では正常動作しているようなので、コードの問題ではなく、OSやExcelのバージョンによる問題かネット環境の問題なのだと思われます。OSはWindows2000でExcelはExcel2000を使用していますが、おそらくはネット環境に問題があるのだと思います。Excel VBAのWEBクエリ取得処理はサーバーから返信が来なかった場合に対する処理が欠けていると推測します。トラフィックが大きく、不安定な環境だとWEBクエリを利用した手法は困難だということで、他の手法を検討します。
コードの問題では無いことが確認できただけで大助かりです。
とても感謝しております。
本当にありがとうございました。 m(_ _)m

【32999】Re:WEBクエリ取得中のまま固まってしまう
お礼  おさる  - 05/12/28(水) 16:33 -

引用なし
パスワード
   原因はネット環境にありそうなことが分かりました。
かみちゃんさん、Keinさん、ご助言の数々ありがとうございました。

【33000】Re:WEBクエリ取得中のまま固まってしまう
発言  かみちゃん E-MAIL  - 05/12/28(水) 16:34 -

引用なし
パスワード
   こんにちは。かみちゃん です。

>早速確認してみましたが、結果は私のコードと同じようにある程度まで正常に動作していましたが、途中で「Web接続中・・・」表示のまま固まってしまいました。かみちゃんさんの環境では正常動作しているようなので、コードの問題ではなく、OSやExcelのバージョンによる問題かネット環境の問題なのだと思われます。

私は、WindowsXP HomeEdition + Excel2002 SP3 で動作確認しました。
回線は、光回線です。
コードを提示したときにこの情報を書いておけばよかったですね。

>Excel VBAのWEBクエリ取得処理はサーバーから返信が来なかった場合に対する処理が欠けていると推測します。トラフィックが大きく、不安定な環境だとWEBクエリを利用した手法は困難だということで、他の手法を検討します。

Internet Explorer(IE)を直接制御するという方法もありますが、こちらの方は、
HTMLの解析が必要ですので、HTMLの知識が必要になります。

以下のURLでIEの制御方法については、参考になるかもしれません。
http://www.ken3.org/cgi-bin/group/vba_ie.asp

【33001】Re:WEBクエリ取得中のまま固まってしまう
お礼  おさる  - 05/12/28(水) 16:44 -

引用なし
パスワード
   >Internet Explorer(IE)を直接制御するという方法もありますが、こちらの方は、
>HTMLの解析が必要ですので、HTMLの知識が必要になります。
>
>以下のURLでIEの制御方法については、参考になるかもしれません。
>http://www.ken3.org/cgi-bin/group/vba_ie.asp

最後の最後まで、本当にありがとうございます。
是非、参考にさせてもらいます。
お世話になりました。

【33006】Re:WEBクエリ取得中のまま固まってしまう
回答  かみちゃん E-MAIL  - 05/12/28(水) 23:45 -

引用なし
パスワード
   こんにちは。かみちゃん です。

>>Internet Explorer(IE)を直接制御するという方法もありますが、こちらの方は、
>>HTMLの解析が必要ですので、HTMLの知識が必要になります。
>>
>>以下のURLでIEの制御方法については、参考になるかもしれません。
>>http://www.ken3.org/cgi-bin/group/vba_ie.asp
>
>最後の最後まで、本当にありがとうございます。
>是非、参考にさせてもらいます。

すでに解決済みかもしれませんが、一応、IEを直接制御する方法で書き直してみました。
回線が混んでいるせいか、さきほど、取得完了まで20分かかりましたが、問題なく取得することができました。

Sub Macro2()
 '参考URL
 'http://www.ken3.org/vba/backno/vba097.html

 Dim objIE As Object 'IEオブジェクト参照用
 Dim objITEM As Object
 Dim Sh1 As Worksheet, Sh2 As Worksheet, Sh3 As Worksheet
 Dim ii As Long
 Dim market As String, strCode As String
 
 'Dt010 取引値 9/15 226
 'Dt030 前日比 -8 (-3.42%)
 'Dt031 前日比 -8 (-3.42%)
 'Dt040 前日終値 234
 'Dt050 出来高 26,927,000
 'Dt060 時価総額 25,543百万円
 Dim Dt010 As Currency, Dt030 As Currency, Dt031 As Double, Dt040 As Currency, Dt050 As Currency, Dt060 As Currency
 'Dt110 始値 224
 'Dt120 高値 231
 'Dt130 安値 214
 'Dt140 売気配 ---
 'Dt150 買気配 ---
 'Dt160 発行済株式数 113,023,000株
 Dim Dt110 As Currency, Dt120 As Currency, Dt130 As Currency, Dt140 As Currency, Dt150 As Currency, Dt160 As Currency
 'Dt210 配当利回り 0.0044
 'Dt220 1株配当 1.00円
 'Dt230 株価収益率 (連) 11.44倍
 'Dt240 1株利益 (連) 19.76円
 'Dt250 純資産倍率 (連) 1.26倍
 'Dt260 1株株主資本 (連) 179.51円
 Dim Dt210 As Double, Dt220 As Currency, Dt230 As Double, Dt240 As Currency, Dt250 As Double, Dt260 As Currency
 'Dt310 株主資本比率 (連) 3.0%
 'Dt320 株主資本利益率 (連) 11.86%
 'Dt330 総資産利益率 (連) 0.33%
 'Dt340 調整1株益 (連) 19.75円
 'Dt350 決算年月 2005年3月
 'Dt360 単元株数 1,000株
 'Dt350 決算年月が"---"表示の場合があるため、Date型ではなくString型で宣言する
 Dim Dt310 As Double, Dt320 As Double, Dt330 As Double, Dt340 As Currency, Dt350 As String, Dt360 As Currency
 
 Dim St As String, MyURL As String
 Dim StartRow As Long, InputRow As Long
 Dim TgN As String, CpN As String
 Const URL As String = "http://quote.yahoo.co.jp/q?s="
 Dim strSplit As String
 
 '処理時間を計測する。
 Dim StartTime As Date
 
 '処理時間を計測する。
 StartTime = Now()

 Set Sh1 = Worksheets("Sheet1") '取得結果出力シート
 Set Sh2 = Worksheets("Sheet2") 'Webクエリ作業シート
 Set Sh3 = Worksheets("Sheet3") '抽出銘柄コード一覧設定シート
 If IsEmpty(Sh3.Range("A2").Value) Then GoTo ELine
 Application.StatusBar = False
 
 ii = 2
 StartRow = ii
 If Sh1.Range("S65536").End(xlUp).Row = StartRow Then
  With Sh1.Range("A2", Sh1.Range("S65536").End(xlUp))
   .ClearContents
   .NumberFormatLocal = "G/標準"
  End With
 End If
 
 Sh1.Range("A1").Resize(, 19) = Array("銘柄コード", "銘柄名", "市場", "始値", "高値", "安値", "終値", "出来高", "発行済株式数", "1株利益", "1株配当", "株価収益率", "純資産倍率", "1株株主資本", "株主資本比率", "株主資本利益率", "総資産利益率", "決算年月", "単元株数")
 'インターネットエクスプローラーのオブジェクトを作る
 Set objIE = CreateObject("InternetExplorer.application")
 Do Until Sh3.Cells(StartRow, "A").Value = ""
  InputRow = 1
  St = ""
  '50銘柄単位ずつ処理する
  Do Until InputRow > 50 Or Sh3.Cells(StartRow - 1 + InputRow, "A").Value = ""
   If IsNumeric(Sh3.Cells(StartRow - 1 + InputRow, "A").Value) And Len(Sh3.Cells(StartRow - 1 + InputRow, "A").Value) = 4 Then
    St = St & Sh3.Cells(StartRow - 1 + InputRow, "A").Value & "+"
    InputRow = InputRow + 1
   End If
  Loop
  StartRow = StartRow + InputRow - 1
 
  If St = "" Then GoTo ELine
  St = Left$(St, Len(St) - 1)
  MyURL = URL & St & "&d=t"
  With Application
   .ScreenUpdating = False
   .DisplayAlerts = False
  End With
 
  With objIE
   .Visible = True
     
   '文字列で指定したURLに飛ぶ
   .Navigate MyURL
  
   '表示終了まで待つ
   Do While .Busy Or .ReadyState <> 4
    DoEvents
   Loop
   
   For Each objITEM In .document.getElementsByTagName("TABLE")
    If InStr(objITEM.Rows(0).Cells(0).InnerText, "関連情報") <> 0 Then
     TgN = Trim(objITEM.Rows(0).Cells(0).InnerText)
     '銘柄名に「(株)」という文字があった場合の対応
     If InStr(TgN, "(株)") <> 0 Then
      If InStr(TgN, "(株)") = 1 Then
       CpN = Left$(TgN, InStr(4, TgN, "(") - 1)
      Else
       CpN = Left$(TgN, InStr(1, TgN, ")"))
      End If
     Else
      CpN = Left$(TgN, InStr(1, TgN, "(") - 1)
     End If
     '市場名を取得
     market = Mid(objITEM.Rows(0).Cells(0).InnerText, 1, InStr(objITEM.Rows(0).Cells(0).InnerText, ":") - 1)
     If InStrRev(market, "(") <> 0 Then
      market = Mid(market, InStrRev(market, "(") + 1)
     End If
     strCode = Mid(objITEM.Rows(0).Cells(0).InnerText, InStr(objITEM.Rows(0).Cells(0).InnerText, ":") + 1)
     If InStrRev(strCode, ")") <> 0 Then
      strCode = Mid(strCode, 1, InStrRev(strCode, ")") - 1)
     End If
     
     '取引値(終値)
     Dt010 = Val(Replace(Split(objITEM.Rows(1).Cells(0).InnerText, " ")(1), ",", ""))
     '前日比
     strSplit = Split(objITEM.Rows(1).Cells(1).InnerText, vbLf)(1)
     Dt030 = Val(Replace(Split(strSplit, " ")(0), ",", ""))
     Dt031 = Val(Replace(Replace(Replace(Split(strSplit, " ")(1), "(", ""), "%)", ""), ",", "")) / 100
     '前日終値
     Dt040 = Val(Replace(Split(objITEM.Rows(1).Cells(2).InnerText, vbLf)(1), ",", ""))
     '出来高
     Dt050 = Val(Replace(Split(objITEM.Rows(1).Cells(3).InnerText, vbLf)(1), ",", ""))
     '時価総額
     Dt060 = Val(Replace(Split(objITEM.Rows(1).Cells(4).InnerText, vbLf)(1), ",", ""))
     '始値
     Dt110 = Val(Replace(Split(objITEM.Rows(2).Cells(0).InnerText, vbLf)(1), ",", ""))
     '高値
     Dt120 = Val(Replace(Split(objITEM.Rows(2).Cells(1).InnerText, vbLf)(1), ",", ""))
     '安値
     Dt130 = Val(Replace(Split(objITEM.Rows(2).Cells(2).InnerText, vbLf)(1), ",", ""))
     '売気配
     Dt140 = Val(Replace(Split(objITEM.Rows(2).Cells(3).InnerText, vbLf)(1), ",", ""))
     '買気配
     Dt150 = Val(Replace(Split(objITEM.Rows(2).Cells(4).InnerText, vbLf)(1), ",", ""))
     '発行済株式数
     Dt160 = Val(Replace(Split(objITEM.Rows(2).Cells(5).InnerText, vbLf)(1), ",", ""))
     '配当利回り
     Dt210 = Val(Replace(Replace(Split(objITEM.Rows(3).Cells(0).InnerText, vbLf)(1), ",", ""), "%", "")) / 100
     '1株配当
     Dt220 = Val(Replace(Split(objITEM.Rows(3).Cells(1).InnerText, vbLf)(1), ",", ""))
     '株価収益率
     strSplit = Split(objITEM.Rows(3).Cells(2).InnerText, vbLf)(1)
     Dt230 = Val(Replace(Split(strSplit, " ")(UBound(Split(strSplit, " "))), ",", ""))
     '1株利益
     strSplit = Split(objITEM.Rows(3).Cells(3).InnerText, vbLf)(1)
     Dt240 = Val(Replace(Split(strSplit, " ")(UBound(Split(strSplit, " "))), ",", ""))
     '純資産倍率
     strSplit = Split(objITEM.Rows(3).Cells(4).InnerText, vbLf)(1)
     Dt250 = Val(Replace(Split(strSplit, " ")(UBound(Split(strSplit, " "))), ",", ""))
     '1株株主資本
     strSplit = Split(objITEM.Rows(3).Cells(5).InnerText, vbLf)(1)
     Dt260 = Val(Replace(Split(strSplit, " ")(UBound(Split(strSplit, " "))), ",", ""))
     '株主資本比率
     strSplit = Split(objITEM.Rows(4).Cells(0).InnerText, vbLf)(1)
     Dt310 = Val(Replace(Replace(Split(strSplit, " ")(UBound(Split(strSplit, " "))), ",", ""), "%", "")) / 100
     '株主資本利益率
     strSplit = Split(objITEM.Rows(4).Cells(1).InnerText, vbLf)(1)
     Dt320 = Val(Replace(Replace(Split(strSplit, " ")(UBound(Split(strSplit, " "))), ",", ""), "%", "")) / 100
     '総資産利益率
     strSplit = Split(objITEM.Rows(4).Cells(2).InnerText, vbLf)(1)
     Dt330 = Val(Replace(Replace(Split(strSplit, " ")(UBound(Split(strSplit, " "))), ",", ""), "%", "")) / 100
     '調整1株益
     strSplit = Split(objITEM.Rows(4).Cells(3).InnerText, vbLf)(1)
     Dt340 = Val(Replace(Replace(Split(strSplit, " ")(UBound(Split(strSplit, " "))), ",", ""), "%", ""))
     '決算年月
     strSplit = Split(objITEM.Rows(4).Cells(4).InnerText, vbLf)(1)
     If IsDate(strSplit) Then
      Dt350 = Format(strSplit, "yyyy年mm月")
     Else
      Dt350 = ""
     End If
     '単元株数
     Dt360 = Val(Replace(Split(objITEM.Rows(4).Cells(5).InnerText, vbLf)(1), ",", ""))
'    'セルに出力する。
'    '始値  高値  安値  終値  出来高 発行済株式数 1株利益 1株配当 株価収益率 純資産倍率 1株株主資本 株主資本比率 株主資本利益率 総資産利益率 決算年月 単元株数
'    'Dt110 Dt120 Dt130 Dt010 Dt050  Dt160     Dt240  Dt220  Dt230    Dt250    Dt260    Dt310     Dt320      Dt330     Dt350   Dt360
    Sh1.Cells(ii, 1).Resize(, 19).Value = _
     Array(strCode, CpN, market, Dt110, Dt120, Dt130, Dt010, Dt050, Dt160, Dt240, Dt220, Dt230, Dt250, Dt260, Dt310, Dt320, Dt330, Dt350, Dt360)
    ii = ii + 1
    End If
   Next
  End With
 Loop
 'インターネットエクスプローラを閉じる
 objIE.Quit
 Set objIE = Nothing
 
 '抽出したデータのセルの書式設定
 Range("A2", Range("S65536").End(xlUp)).NumberFormatLocal = "G/標準"
 Range("R2", Range("R65536").End(xlUp)).NumberFormatLocal = "yyyy""年""m""月"";@"
 
 With Application
   .ScreenUpdating = True
   .DisplayAlerts = True
 End With
 '処理時間を表示する。 2005.10.02 UpDate by kamicha1
 MsgBox "株価情報取得処理を終了しました" & vbCrLf & _
     " 処理時間:" & Format(Now() - StartTime, "hh:mm:ss")
ELine:
 Set Sh1 = Nothing: Set Sh2 = Nothing: Set Sh3 = Nothing
End Sub

【33030】Re:WEBクエリ取得中のまま固まってしまう
お礼  おさる  - 05/12/29(木) 12:08 -

引用なし
パスワード
   >すでに解決済みかもしれませんが、一応、IEを直接制御する方法で書き直してみました。
>回線が混んでいるせいか、さきほど、取得完了まで20分かかりましたが、問題なく取得することができました。

!!!!!
驚きです。ここまで親切にしてもらえるとは!
(もちろん、まだ解決していませんでした。)
もしかして、かみちゃんは神ちゃん...そうか神様だったんですね。
ということで、神のお告げにしたがい早速実行。
しばしまつこと...おおっ、今まで一度も超えていない3000台に突入。「これは行ける」。5分後...実行時エラー!なな何が?
開かれたIE画面を見ると中途半端な表示のまま完了状態。「IE、今度はお前か!!!」。読み出そうとするデータが無くてエラーになったようです。まぁ、こんなこともたまにはあります。Excel君が死んだわけではないので、対処方法もあります。でも、とりあえず、再トライですんなり行くはず。という訳で再トライ。5分後...「さっきから進捗が無いような...」...10分後、「やはり進んでない」。IE画面を確認すると、今度は完了状態にならずに、アクセス状態のまま。「くっ、やはりネット環境が悪いとダメなのか!」、とりあえずIEを閉じると、実行時エラー。「そうか、あたりまえだけどExcel君は生きているんだ!それならタイムアウト処理を追加して更新しなおせば良いんだ!」。とりあえず、更新処理方法を調べるのは後にして、手っ取り早くIE閉じて再起動させる処理を追加。

TIME_OUT:                            '追加
  With objIE
   '.Visible = True
  
   '文字列で指定したURLに飛ぶ
   .Navigate MyURL
 
   '表示終了まで待つ(タイムアウト処理追加)
   TimeOutTime = Now()                    '追加
   TimeOutTime = TimeOutTime + "00:01:00"           '追加
   Do While .Busy Or .ReadyState <> 4
    DoEvents
    '追加↓↓↓↓↓↓
    If TimeOutTime < Now() Then
      objIE.Qui
      Set objIE = Nothing
      MsgBox "タイムアウトが発生しました!"         '確認用
      Set objIE = CreateObject("InternetExplorer.application")
      GoTo TIME_OUT
    End If
    'ここまで↑↑↑↑
   Loop

これにて再々トライ。5分後、タイムアウト表示でOKをクリック、「行けそうだ」。その後3回のタイムアウトが表示されるも、無事終了表示(約48分)。「やったぜ父ちゃん」思わず星飛雄馬のように叫んでしまいました。

そんな訳で奮闘日記のようになってしまいましたが、等問題はコンプリートです。
かみちゃんさん本当にありがとうございます。
感謝感激です(p^^)p♪♪♪q(^^q) m(_ _)m

【33044】Re:WEBクエリ取得中のまま固まってしまう
発言  かみちゃん E-MAIL  - 05/12/29(木) 21:45 -

引用なし
パスワード
   こんにちは。かみちゃん です。

>今まで一度も超えていない3000台に突入。「これは行ける」。5分後...実行時エラー!なな何が?
>開かれたIE画面を見ると中途半端な表示のまま完了状態。「IE、今度はお前か!!!」。読み出そうとするデータが無くてエラーになったようです。

実行時エラーの内容と、どのコードでエラーになったか知りたいですね。
また、「中途半端な表示の状態」という事象も、詳しく知りたいところです。

>IE画面を確認すると、今度は完了状態にならずに、アクセス状態のまま。

この事象も、あまりよくわかりません。
詳しく説明していただけるとありがたいのですが。

>これにて再々トライ。5分後、タイムアウト表示でOKをクリック、「行けそうだ」。その後3回のタイムアウトが表示されるも、無事終了表示(約48分)。

ネット回線は、ダイアルアップですか?ADSL等常時接続回線でしょうか?

>当問題はコンプリートです。

ちなみに、私の環境は、
WindowsXP、Excel2002SP3、IE6.0、光回線
で検証しました。

何かあれば、ご連絡いただければと思います。

【33394】Re:WEBクエリ取得中のまま固まってしまう
お礼  おさる  - 06/1/10(火) 15:28 -

引用なし
パスワード
   おさるです。
長い正月モードのため、レスが遅れてすいません。

>>開かれたIE画面を見ると中途半端な表示のまま完了状態。「IE、今度はお前か!!!」。読み出そうとするデータが無くてエラーになったようです。
>
>実行時エラーの内容と、どのコードでエラーになったか知りたいですね。
>また、「中途半端な表示の状態」という事象も、詳しく知りたいところです。

上記の件ですが、「中途半端な表示のまま完了状態」というのは簡単に説明すると、IEがサーバーからデータ取得中に「中止」を実行したのと同じ状態です。IEはエラー表示するわけでもなく、データ取得も止めてしまっており、表示データは途中から欠落している状態です。正式なエラー場所は忘れましたが、表データを参照するコード(例えば下記)で表が欠落しているため、エラーとなっていました。

strSplit = Split(objITEM.Rows(3).Cells(4).InnerText, vbLf)(1)


>>IE画面を確認すると、今度は完了状態にならずに、アクセス状態のまま。
>
>この事象も、あまりよくわかりません。
>詳しく説明していただけるとありがたいのですが。

これは、上述の問題と相反して、IEがエラーを表示するわけでもなく、データ取得をあきらめてもいない状態です(さらに頬って置けばエラーなったのかもしれませんが、余りに長かったので中止を実行しました。経験上、頬って置いてもエラーとなるか、そなままの状態が続くので)。


>ネット回線は、ダイアルアップですか?ADSL等常時接続回線でしょうか?

すいません。正確な環境がわかりません。社内LANを使用していますが、規模が大きいので、決められた管理者のみで私はその辺りに触れる機会がありません(おそらくは専用回線です)。大勢ぶら下がっているので、末端はADSLより悪い環境です(ダイアルアップよりは良いと思います)。


説明不足で申し訳ありませんでした。

8423 / 13646 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free