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

質問

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

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

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

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

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

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

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

よろしくお願いします。

回答No.1

KenKen_SP

標準モジュールに貼り付けて実行します。即席で書いたコードなので、
よくよく動作確認してませんが。。とりあえず、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