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

締切り済みの質問

ヤフーファイナンスとエクセルの組み合わせ

少々細かい質問内容になります。

私は、ヤフーファイナンスの値上がり率ランキングをエクセルにコピペ(保存)したいのです。

ヤfy-ランキング
http://quoterank.yahoo.co.jp/ranking/search?b=1&mk=11&kd=1&ca=1&tm=day&

[方法]
ランキングをコピぺして、エクセルに貼り付けることはできます。
(ただ、一緒にランキング内の【[関連情報]の「チャート]「時系列」~「レポート」】まで一緒に貼り付いてします)

エクセルに保存した時は、この[関連情報]一式を切り取り、または完全に削除したいのですがどうしたらよいでしょうか?

[関連情報]一式だけ削除することができないのです。

どうか削除の方法を教えてください。

よろしくお願いします。

投稿日時 - 2007-12-21 00:55:19

QNo.3615348

すぐに回答ほしいです

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

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

回答(1)

ANo.1

標準モジュールに貼り付けて実行します。即席で書いたコードなので、
よくよく動作確認してませんが。。とりあえず、100件(5P*20件/P)
のデータを一度で Excel に取り込みます。
コードの説明書きを読めば、Yahoo 側に変更があっても多少の修正で
対応できるでしょう。多分。

コードの URL の記載箇所で不要な・記号等が入っていたら除去して
下さい。


Option Explicit

Private Declare Sub Sleep Lib "kernel32.dll" ( _
    ByVal dwMilliseconds As Long)

Sub YahooFinanceRanking()

  ' // WEB クエリ 問い合せ先 パラメータ情報: b=表示開始No
  Const BASURL_ As String = "http://quoterank.yahoo.co.jp/ranking/search?b="
  Const PRMURL_ As String = "&mk=11&kd=1&ca=1&tm=day&"
  ' // WEB クエリ 取得テーブル番号(文字列で)将来変更される可能性がある
  Const TBLNUM_ As String = "19"
  ' // 最後に削除する列のフィールド名
  Const DELCAP_ As String = "関連情報"
  ' // ページ数は 12/21 現在で 10 ?? 20 でも取得できるようだけど...
  Const MAXPAG_ As Long = 5
  ' // 1ページ当たりの表示データ数は 12/21 現在で 20 みたい
  Const DATCNT_ As Long = 20
  
  Dim sConn As String
  Dim rDest As Range
  Dim rDel As Range
  Dim lPage As Long
  Dim lPos As Long
  Dim Sh  As Worksheet
  
  ' // シート初期化
  Set Sh = ActiveSheet
  Sh.Cells.Delete
  
  Application.ScreenUpdating = False
  Application.Cursor = xlWait
  
  lPos = 1
  ' // 最終ページまで連続データ取得
  For lPage = 1 To MAXPAG_
    ' // 貼り付け先
    Set rDest = Sh.Cells(Rows.Count, "A").End(xlUp).Offset(1)
    ' // コネクション文字列を生成
    sConn = "URL;" & BASURL_ & CStr(lPos) & PRMURL_
    With Sh.QueryTables.Add(Connection:=sConn, Destination:=rDest)
      .RowNumbers = False
      .PreserveFormatting = True
      .RefreshStyle = xlInsertDeleteCells
      .AdjustColumnWidth = False
      .RefreshPeriod = 0
      .WebSelectionType = xlSpecifiedTables
      .WebFormatting = xlWebFormattingAll
      .WebTables = TBLNUM_
      .Refresh BackgroundQuery:=False
      .Delete
    End With
    lPos = lPos + DATCNT_
    ' // 連続処理でサーバーに負荷をかけ過ぎてもアレなので数秒必ず待機すること。
    ' // また、そうしないと DOM 解析が追いつかず、期待した結果も得られない。
    DoEvents
    Application.StatusBar = "待機中...(・∀・)"
    Call Sleep(2000)
    DoEvents
    Application.StatusBar = False
  Next
  
  ' // 不要列削除
  Set rDel = Sh.Cells.Find(What:=DELCAP_, _
               LookIn:=xlValues, _
               LookAt:=xlWhole)
  If Not rDel Is Nothing Then
    rDel.EntireColumn.Delete Shift:=xlShiftToLeft
  End If
    
  ' // 仕上げ
  With Sh.Cells(2, "A").CurrentRegion
    .Borders.Weight = xlThin
    With .EntireColumn
      .ColumnWidth = 255
      .AutoFit
    End With
    .EntireRow.AutoFit
  End With
  With Sh.Cells(1, 1)
    .Font.ColorIndex = 46
    .Font.Bold = True
    .Value = "Yahoo!ファイナンス - 株式ランキング(マーケット関連)"
  End With
  Application.ScreenUpdating = True
  Application.Cursor = xlDefault
  
  MsgBox "(・∀・)完了!"

End Sub

投稿日時 - 2007-12-21 16:58:01

あなたにオススメの質問