Excel VBA質問箱 IV

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

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


48677 / 76732 ←次へ | 前へ→

【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

0 hits

【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 お礼

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