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