ツールの補助説明1

1.「t11-今日の値動き」を改善して「詳細情報」を取得する方法

（2/19(Tue) 21:23 　けんさんからの質問）
http://profile.yahoo.co.jp/independent/9997
上記URLにあるようにyahooファイナスに掲載されている全上場企業の単独決算情報を一括でエクセルにおとしたいのですが、どのようなマクロを組めばよろしいでしょうか？

＜回答＞
情報は1銘柄1ページであり、KIkabu(G)に「詳細情報作成」の項目がありますが、これと同じようなマクロを組めばよいと思います。
なお、取得方法のみであれば最近出版した本の「PART11：今日の値動き表の作成」と同じです。ただし、詳細情報の場合は取得したデータを1銘柄ずつ別シートに貼り付けてまとめる操作が必要です。

(1)概略
・「t11-今日の値動き」を改善して「詳細情報」を取得するマクロを説明しますが、ダイアログの改善も行うと初心者には判りづらいと思うので、詳細情報を取得してリストシートへ貼り付ける方法を説明します。

・マクロスタートは、メニューの「ツール」「マクロ」「マクロ」から「詳細情報取得」を指定して実行します。なお、下記を「ThisWorkbook」マクロシートへ追加すればメニューの「t11-今日の値動き」へ「詳細情報取得」が追加されるのでこの場合はメニュー項目から実行できます（37p　事例1-1参照）。


 .Controls.Add Type:=msoControlButton
    With .Controls(2)
        .Caption = "詳細情報取得"
        .OnAction = "詳細情報取得"
    End With

・Module1への追加変更は特にありません。（Public Const teblsua As Integer = 14　は最近　13　に変更になっている）
なお、今回追加の詳細情報取得には「数字化」や「列幅調整」等はないので必要な方は適当に追加して下さい。

・下図が作成した詳細情報例

(2)Module2へ変数宣言の追加
Module2シートの最上段に変数定数の宣言のがありますが、そこに以下の3行を追加


Dim hazime As Integer    'はじめ1
Dim sheetn1 As String     '詳細シート名1
Dim sheetn2 As String     '詳細シート名2

(3)Module2の詳細情報の正常取得の確認を追加
tabel確認プロシージャへ以下の赤色部を追加（A2セルに「取引値」で正常取得）


Sub tabel確認()
If Cells(cend2, 1) = "コード" Then
   errtab = 0
   Exit Sub
End If

'詳細情報用に追加
If Cells(2, 1) = "取引値" Then
   errtab = 0
   Exit Sub
End If

    If errtab > 9 Then

(4)Module2へ詳細情報取得プロシージャ追加
Module2へ以下のプロシージャを貼り付けて下さい（使用している変数名の関係でModule2へ貼付のこと)。


Sub 詳細情報取得()
Call 銘柄リスト作成
Application.ScreenUpdating = True
Call ダイアログ  'プログレス表示用
  
    Worksheets("リスト").Select
    Call 銘柄を配列へ
    Call kabu1c
End Sub
'-----------------------------------------------------------------------
Sub kabu1c()
     shurui = "&d=t&k=c3&h=on&z=m"
     sheetn1 = "詳細仮"
     sheetn2 = "詳細情報"
     pgmsg = "詳細情報取得中"
      Call 詳細取得
       Call kabu9
End Sub
'-----------------------------------------------------------------------
Sub 詳細取得()
Application.ScreenUpdating = False

cend1 = meino(0, 0)
cend2 = 1

'シート詳細情報があったら削除
For Each sheet_name In Worksheets
    If sheet_name.Name = (sheetn2) Then
        Worksheets(sheetn2).Select
            Application.DisplayAlerts = False
                ActiveWindow.SelectedSheets.Delete
            Application.DisplayAlerts = True
    End If
Next

'シート名変更
Sheets("リスト").Name = sheetn2
Sheets.Add.Name = sheetn1

'
teblsu = teblsua
cnt = 0: urlka = "":  pg = 0: pgcar = "&h8b0000"
hazime = 0

For i = 1 To cend1 - 1
    Worksheets(sheetn1).Select
    
'過去データ削除
    Range("A1:H10").Select
    Selection.ClearContents
    Range("A1").Select
    For Each FieldName In ActiveWorkbook.Names
       FieldName.Delete
    Next FieldName
   
    urlka = urly & meino(0, i + 1)
'取得
        urlk = urlka & shurui
        urlka = ""
        プログレス
        Call ダウンロード
        
        Call 貼り付け
        Application.ScreenUpdating = True
        Application.ScreenUpdating = False
Next

'仮データのブックを閉じる
    Worksheets(sheetn1).Select
    Application.DisplayAlerts = False
            ActiveWindow.SelectedSheets.Delete
    Application.DisplayAlerts = True

End Sub
'-----------------------------------------------------------------------
Sub 貼り付け()
ReDim da(24)

If hazime = 0 Then
    hazime = 1
    n = 1
    For ia = 2 To 9 Step 2
        For j = 1 To 6
            da(n) = Cells(ia, j)
            n = n + 1
        Next
    Next
    Cells(2, 1) = ""
    
 '表題の貼り付け
    Worksheets(sheetn2).Select
    
    For ia = 1 To 24
        Cells(1, ia + 2) = da(ia)
    Next
End If
 
 ReDim da(24)
    Worksheets(sheetn1).Select
        da(0) = Cells(1, 1)
    n = 1
    For ia = 3 To 9 Step 2
        For j = 1 To 6
            da(n) = Cells(ia, j)
            n = n + 1
        Next
    Next

 '貼り付け
    Worksheets(sheetn2).Select
    
    For ia = 0 To 24
        Cells(i + 1, ia + 2) = da(ia)
    Next
End Sub

【ホ－ム】