Attribute VB_Name = "Module1"
'#######################################################
'
'   「株価時系列収集マクロ_K」　by Garakutaen
'       着手    2025/04/20
'       改修    2025/04/30
'       改造    2025/05/05
'       Debug   2025/05/06
'
'  作業用Sheet1、Sheet2の2枚が必要、クリア後に戻す
'#######################################################
'銘柄指定用メニュー
Sub Macro1()
    UserForm1.Show
    End
End Sub

'#######################################################
'webページを1ページ開く、ワークシート"Sheet1, 2"を2枚開く
'銘柄コードはTextBox1から。最大ページ数はTextBox2から。
Sub Main(kcd As Integer, pmax As Integer)

Dim ie, win As Object
Dim oTag, csh As Object
Dim doc As HTMLDocument
Dim nsav, Ttl As String
Dim n As Long
Dim pnum, psav As Integer

'******************************
'銘柄コードは、「userForm1」から得る
'    kcd = xxxx
'******************************
'スタートページ番号は +1
pnum = 0
'上部下げ行数（来月日入れ用は、-3で考えること）
ofr = 15
'1ページ当たりの日々データの行数
dlen = 30

'最大は10ページ
If pmax = 0 Then pmax = 1
If pmax > 10 Then
    pmax = 10
    UserForm1.TextBox2.Value = 10
End If
    
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'指定された最後のページまで繰り返す
Do While pnum < pmax
    psav = UserForm1.TextBox2.Value
    pnum = pnum + 1
    UserForm1.TextBox2.Text = pnum
    UserForm1.TextBox2.ForeColor = &H40C0&
'IEを起動
    Set ie = CreateObject("InternetExplorer.Application")
    ie.Visible = False
'IE画面サイズなどの指定
    ie.Width = 500
    ie.Height = 1000
    ie.Left = 0
    ie.Top = 0
    ie.Resizable = True

'URLを指定
    On Error GoTo exerr
    ie.Navigate "https://kabutan.jp/stock/kabuka?code=" & kcd & "&ashi=day&page=" & pnum

'IEを待機
    Call IEWait(ie)

'タイトルを得る
    Set csh = CreateObject("Shell.Application")
    For Each win In csh.Windows
        Ttl = ""
        On Error Resume Next
        Ttl = win.Document.Title
    Next
'..............................................................................
'タイトルを転写
    Sheet2.Range("A1").Value = Ttl
'タイトル長過ぎ！..よって後部の削除とシート名修正
    n = InStr(1, Ttl, "】")
    If n > 0 Then
        Ttl = Left(Sheet2.Range("A1"), n)
        Sheet2.Range("A1") = Ttl
    End If
    
'フォーム上に表示
    UserForm1.Label1.Caption = Ttl
'..............................................................................
'音声メッセージ
    If UserForm1.ToggleButton1 = True Then
        If pnum = 1 Then
            Application.Speech.Speak pnum & "ページめから、始めます"
        Else
            Application.Speech.Speak pnum & "ページめ、処理ちゅうーです"
        End If
    End If
'..............................................................................
'シートを生成、用意
    Call MakeWshet(ie, win, pnum)
'データの転送
    Call Movedata(pnum, ofr, dlen)

'終了処理
    ie.Quit
    Set ie = Nothing
Loop

'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
    Sheet2.Select
    With Selection
'前日比桁を削除
        .Range("F:G").Delete
'日付桁、数値桁サイズを揃える
        .Columns(1).ColumnWidth = 11
        .Columns(2).ColumnWidth = 8
        .Columns(3).ColumnWidth = 8
        .Columns(4).ColumnWidth = 8
        .Columns(5).ColumnWidth = 8
        .Columns(6).ColumnWidth = 12
'2行目の文字列を中央揃え
        .Range("A3:F3").HorizontalAlignment = xlCenterAcrossSelection
'最高値、最安値の転写
        .Cells(2, 1).Value = " 最高｜最安"
        .Cells(2, 3).Value = UserForm1.Label6.Caption
        .Cells(2, 4).Value = UserForm1.Label7.Caption
    End With
'------------------------------------------------------------------------------

'銘柄シート名の保存
    nsav = Sheet2.Range("A1").Value
'データ・収納シートをコピーして最後へ
    Sheet2.Copy After:=Worksheets("Sheet3")
'同名のシートを事前消去
    Application.DisplayAlerts = False
    On Error Resume Next
    Worksheets(nsav).Delete
    Application.DisplayAlerts = True
'銘柄名を複写
    ActiveSheet.Name = nsav

'..............................................................................
'前部空白行へ後日の月日を追加記入
    For i = 4 To ofr - 1
        Cells(i, 1) = Year(Now + 12 - i) & "/" & Month(Now + 12 - i) & "/" & Day(Now + 12 - i)
    Next
'月日表示の変更
    For i = 3 To 500
'        Range("A" & i).NumberFormatLocal = "yyyy/mm/dd"    'この方式は不適！
        Range("A" & i) = Format(Range("A" & i), "yyyy/mm/dd")
        Range("B" & i & ":F" & i).NumberFormatLocal = "#,#.0"
        Range("H" & i).NumberFormatLocal = "#,#"
    Next
'不要行の消去
    If pnum = 1 Then Range("B43:F50").Clear
'------------------------------------------------------------------------------
'
'使用済みシートをクリア
    Sheet1.Range("A:L").Clear
    Sheet2.Range("A:L").Clear
'カーソルを「日付」の位置へ
    ActiveSheet.Range("A3").Select
'処理中ぺージの表示数を戻す
    UserForm1.TextBox2.Value = psav + 1
    UserForm1.TextBox2.ForeColor = &H0
'音声メッセージ
    If UserForm1.ToggleButton1 = True Then Application.Speech.Speak "処理が、終わりました"
'ieを再描画
    ie.Visible = True
    Exit Sub

'エラー時終了
exerr:
    MsgBox "サイト不明?"
    Application.Speech.Speak "サイトが、読めませーん"
    End
End Sub

'##############################################################################
'IEを待機する関数
Public Function IEWait(ie)
    Do While ie.Busy Or ie.ReadyState < READYSTATE_COMPLETE
        Debug.Print ie.Busy & ":" & ie.ReadyState
        SendKeys "(ENTER)", True
        DoEvents
    Loop
End Function
'
'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
'収集データを取り敢えず、シート1へ書き込む
Sub MakeWshet(ie, win, pnum)
Dim oTD, oTH As Object
    
    Worksheets("Sheet1").Activate
    Cells.NumberFormatLocal = "G/標準"
    
'<TH>行を探して、採取データ_1を"Sheet1"にコピー
    Set doc = ie.Document
    Set oTH = doc.getElementsByTagName("TH")
    n = 0
    For Each oTag In oTH
        n = n + 1
        Cells(n, 1) = oTag.innerText
    Next oTag

'<TD>行を探して、採取データ_2を"Sheet1"にコピ−
    Set oTD = doc.getElementsByTagName("TD")
    n = 0
    For Each oTag In oTD
        n = n + 1
        Cells(n, 2) = oTag.innerText
    Next oTag
    Exit Sub
exmk:
    End
End Sub

'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
Sub Movedata(pnum, ofr, dlen)

'下部の不要な行を消しておく
    Sheet1.Range("A249:C300").Clear

'最高値、最安値の転写
    UserForm1.Label6.Caption = Sheet1.Cells(24, 2).Value
    UserForm1.Label7.Caption = Sheet1.Cells(26, 2).Value

'＋＋＋　数値類の転写　＋＋＋
    With Selection
'日付、始値、．．．（仮：ofr=10、文字群は、最上部三段目へ）
    For j = 1 To 8
        Sheet2.Cells(3, j).Value = Cells(j + 22, 1).Value
    Next
'..............................................................................
'値の転送・・・この辺りを大工夫！
    For k = 1 To 217            '217＝固定値！
        c = (k + 6) Mod 7
        l = Int((k + 6) / 7)
'月日、株価の転写
        If pnum = 1 Then
            Sheet2.Cells(k + ofr + dlen * (pnum - 1), 1) = Sheet1.Cells(k + 30, 1)
            Sheet2.Cells(l + ofr - 1 + dlen * (pnum - 1), c + 2) = Sheet1.Cells(k + 31, 2)
        Else
            Sheet2.Cells(k + ofr - 1 + dlen * (pnum - 1), 1) = Sheet1.Cells(k + 30, 1)
            Sheet2.Cells(l + ofr - 1 + dlen * (pnum - 1), c + 2) = Sheet1.Cells(k + 38, 2)
        End If
'[今日]の月日の転写
        If pnum = 1 Then Sheet2.Cells(ofr, 1).Value = Sheet1.Cells(22, 1).Value
    Next k
    End With
End Sub
'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@