Attribute VB_Name = "Module1"
'##############################################################################
'
'   時系列自動収集マクロ  by Garakutaen
'       着手：2025/4/29
'       改修：2025/5/2
'
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' Sheet1の「A〜C」桁に、時系列データを取り込んで、「D〜J」桁に並べ、
'Sheet3に書き込んで、最後に、それを「指定銘柄シート」にコピーして、完了｡
'頁指定には、最大頁値を指定（空白なら１）。動作中は処理中のページを表示。
'
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Sub Macro1()

UserForm1.CommandButton1.Default = True
UserForm1.CommandButton2.Cancel = True
UserForm1.Show

End Sub

'
Sub Main()
Dim kcd, pnum, psav, pmax, perr, dssw As Integer
Dim ie As InternetExplorer
Dim nsav As String
kcd = 3777
pmax = 1                          '最大頁数
pnum = 1                          '開始頁
perr = 0                          'エラー発生フラグ:1

'銘柄コードを取得
kcd = UserForm1.TextBox1.Text
'空ページ数の時は、1をセット！
pmax = UserForm1.TextBox2.Text
    If pmax = "" Then pmax = 1
    If pmax >= 13 Then pmax = 13
psav = pmax

If UserForm1.ToggleButton1.Value = False Then
    Application.ScreenUpdating = False
Else
    Application.ScreenUpdating = True
End If
'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
'最大ページ分繰返すが、空白ページで終了
Do Until (pnum = pmax + 1) Or (pnum > pmax)

'    If perr = 1 Then GoTo lend
'文字のセットと色替え
    UserForm1.TextBox2.Text = pnum
    UserForm1.TextBox2.ForeColor = &HC0&

'ieをセット
    Set ie = CreateObject("InternetExplorer.Application")
    ie.navigate "https://finance.yahoo.co.jp/quote/" & kcd & ".T/history?&page=" & pnum
    ie.Width = 500
    ie.Height = 1000
    ie.Left = 0
    ie.Top = 0
'    ie.Visible = True
'読み込み完了待ち
    While ie.busy Or ie.ReadyState < READYSTATE_COMPLETE
        DoEvents
    Wend
'------------------------------------------------------------------------------
'音声メッセージ
    If pnum = 1 Then
        Application.Speech.Speak pnum & "ページめ、始めます"
    Else
        Application.Speech.Speak pnum & "ページめ、続けます"
    End If
'------------------------------------------------------------------------------
'リストの作成
    Call Mklst(ie, pnum)
'------------------------------------------------------------------------------
'webページ消去
    ie.Quit
'カウンタ+1
    pnum = pnum + 1

Loop
'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
lend:

'日付揃え
    ActiveSheet.Columns(3).ColumnWidth = 12
    ActiveSheet.Columns(5).ColumnWidth = 8
    ActiveSheet.Columns(6).ColumnWidth = 8
    ActiveSheet.Columns(7).ColumnWidth = 8
    ActiveSheet.Columns(8).ColumnWidth = 8
    ActiveSheet.Columns(9).ColumnWidth = 9
'..............................................................................
'データ・シートの移し替え

'コピーして最後へ
    Worksheets("Sheet1").Copy After:=Worksheets(5)
'銘柄シート名へ変更準備
    nsav = Sheet1.Range("D1").Value
'同名のシートを事前消去、他の使用シート1,2もクリア
    Application.DisplayAlerts = False
    On Error Resume Next
    Worksheets(nsav).Delete
    Sheet1.Cells.Clear
    Sheet2.Cells.Clear
    Application.DisplayAlerts = True
'銘柄シート名へ変更
    ActiveSheet.Name = nsav
    Range("D1").HorizontalAlignment = xlLeft
'..............................................................................
'前部空白行へ後日の月日を追加記入
    For i = 3 To 12
        Cells(i, 4) = Year(Now + 12 - i) & "/" & Month(Now + 12 - i) & "/" & Day(Now + 12 - i)
    Next
'..............................................................................
'シートの整理

'A,B,C桁の削除
    Columns("A:C").Delete
    Columns("G:J").Delete
'月日表示の変更
    For i = 12 To 500
        Range("A" & i) = Format(Range("A" & i), "yyyy/mm/dd")
    Next
    
    UserForm1.TextBox2.Text = psav
    UserForm1.TextBox2.ForeColor = &H0&
'ポジションを先頭へ
    Range("A1").Select
    Application.ScreenUpdating = True
    Application.Speech.Speak "終わりました"
End Sub

'##############################################################################
'Web頁上のデータの転送・転写、表作り
Sub Mklst(ie, pnum)
'Sub Mklst(ie As InternetExplorer)

Dim oTag As Object
Dim doc As HTMLDocument
Dim n, m, c, nc As Long
Dim d As Integer
Dim nttl, itext As String
    n = 0
    m = 0
    c = 0
    d = 0
    ofr = 20 * (pnum - 1) + 10

'------------------------------------------------------------------------------
'作業用シートにつき、必須！
    Sheets("Sheet1").Select

    Cells.NumberFormatLocal = "G/標準"
    Set doc = ie.Document

    For n = 0 To doc.all.Length - 1
        With doc.all(n)
        If .tagName = "TITLE" Then
''''''
            On Error GoTo pend
            nttl = .innerText
'------------------------------------------------------------------------------
'タイトル後部の削除とシート名変更
            nc = InStr(1, nttl, "】")
            If nc > 0 Then Sheet1.Range("D1") = Left(nttl, nc)
        End If
       
        If (.tagName = "TH" Or .tagName = "TD") Then
            m = m + 1
'------------------------------------------------------------------------------
'.innerTextの前部のxlCrLfを除去
            If Left(.innerText, 2) = vbCrLf Then
                nc = Len(.innerText) - 2
                .innerText = Right(.innerText, nc)
            End If
            If .innerText = "" Or .innerText = vbCrLf Then GoTo pend
            Cells(m + 1, 1) = .tagName
            Cells(m + 1, 2) = n
            Cells(m + 1 + ofr, 3) = .innerText
'------------------------------------------------------------------------------
'斜め上に転送
            If m + 1 > 8 Then                       '日付,始値...の部分は、最上位へ
                c = (m + 13) Mod 7
                d = Int((m + 13) / 7)
                Cells(d + ofr, c + 4) = .innerText
            Else                                    'データ部分は下部へ
                c = (m + 13) Mod 7
                d = Int((m + 13) / 7)
                Cells(2, c + 4) = .innerText
            End If
        End If
        End With
    Next
pend:
    perr = 1
    Exit Sub
End Sub
'##############################################################################