ツールの補助説明1

2. 「t11-今日の値動き」を改善して「単独決算情報」を取得する方法

（2/20(Wed) 22:11 　けんさんからの質問）
さっそく　本を購入させていただきました。
そこで思ったのですが、1シート1社の決算情報　をダウンロードするのではなく、表形式にして以下のようにまとめて一括ダウンロードすることもマクロでできますでしょうか？
例銘柄コード　社名　　　　決算期　　　　売上高
9994　　　　(株)やまや　2007年3月期　69,992百万円
9995　　　　(株)イーストン　2007年3月期　47,784百万円

できれば、、サンプルコードいただけると幸いです・・・m(__)mよろしくお願いします。

＜回答＞
本を購入して頂いたとのことで有難う御座います。こちらも誠意を持って対応します。
以下が単独決算情報ダウンロードソースですが、問題点・不明点がありましたら何時でもメールを下さい。

(1)概略
・「t11-今日の値動き」を改善して「単独決算情報」を取得するマクロを説明します。ダイアログも表示しますがこれはプログレス表示用であり非表示でも実行上は問題ない（このマクロではURLを変更しておりボタン等実行できません。プログレスとして使用する場合は不要部は削除して下さい）。

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


 .Controls.Add Type:=msoControlButton
    With .Controls(2)
        .Caption = "単独決算情報取得"
        .OnAction = "単独決算情報取得"
    End With

・Module1への追加変更は下記1件です。
Public Const teblsua As Integer = 14　をこのマクロでは　10　にする）
なお、「列幅調整」や「並べ替えの為の数字化」等はないのでこれは自動記録でもマクロ化できるので必要な方は適当に追加して下さい。

・下図が作成した単独決算情報例(71列まであります）

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


Public Const urly As String = "URL;http://profile.yahoo.co.jp/independent/"

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:D24").Select
    Selection.ClearContents
    Range("A1").Select
    For Each FieldName In ActiveWorkbook.Names
       FieldName.Delete
    Next FieldName
   
'取得
    urlk = urly & meino(0, i + 1)
    プログレス
    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
    For ia = 2 To 24
        da(ia) = Cells(ia, 1)
    Next
    
 '表題の貼り付け
    Worksheets(sheetn2).Select
    
    For j = 1 To 3
        For ia = 2 To 24
            If j = 2 Then
                Cells(1, ia + 24) = "(2前)" & da(ia)
            ElseIf j = 3 Then
                Cells(1, ia + 47) = "(3前)" & da(ia)
            Else
                Cells(1, ia + 1) = "(前期)" & da(ia)
            End If
        Next
    Next
End If
 
 ReDim da(72)
    Worksheets(sheetn1).Select
        
    n = 3
    For j = 1 To 3
        For ia = 2 To 24
            da(n) = Cells(ia, j + 1)
            n = n + 1
        Next
    Next

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

【ホ－ム】