Excel (VBA)

Excel VBAに関するフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(指定なし : 指定なし)
マクロを修正できる方お願いいたします。(取得項目を追加)
投稿日時: 21/05/24 19:49:06
投稿者: tommy6

以前作って頂いたマクロに下記項目を更に追加したいのですが、
修正できる方はいらっしゃいますか。
 
"時価総額"
"発行済株式数"
"配当利回り(会社予想)"
"1株配当(会社予想)"
"PER(会社予想)"
"PBR(実績)"
"EPS(会社予想)"
"BPS(実績)"
"最低購入代金"
"単元株数"
"年初来高値"
"年初来安値"
 
ヤフーから株価を取得するマクロが下記になり、取得項目を増やしたいです。
★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★
Option Explicit
 
Private Sub cmdKabukaGet_Click()
    On Error GoTo ErrorTrap
    Dim wRow As Long
    Dim wNo As Long
    
    '更新確認メッセージ
    If MsgBox("株価を取得します。よろしいですか?", vbQuestion + vbOKCancel, "確認") <> vbOK Then
        GoTo ExitTrap
    End If
     
    'マウスポインタを砂時計にする
    Application.Cursor = xlWait
 
    'A列の6行目から最終行まで処理を繰り返す
    wNo = 1
    For wRow = 6 To Range("A" & Rows.Count).End(xlUp).Row
        Me.Activate
        Me.Cells(wRow, 1).Select
        If (Me.Cells(wRow, 1) >= 1000 And Me.Cells(wRow, 1) <= 9999) Then
            Call GetJikeretu(Cells(wRow, 1), wRow)
        End If
        wNo = wNo + 1
    Next
ExitTrap:
    'マウスポインタを通常に戻す
    Application.Cursor = xlDefault
    Exit Sub
ErrorTrap:
    'エラー処理
    MsgBox "cmdKabukaGet_Click Error!" & Err.Number & ":" & Err.Description, vbExclamation + vbOKOnly, "Error!!"
    Resume ExitTrap
End Sub
 
Private Sub GetJikeretu(prmCode, prmListRow)
    On Error GoTo ErrorTrap
    Dim oHttp As Object
    Dim strURL As String
    Dim strText As String
    Dim arrData() As String
    Dim arrLine() As String
    Dim wIdx1 As Long
    Dim wIdx2 As Long
    Dim wRow As Long
    Dim wClm As Long
    Dim wMaxRow As Long
    Dim wStrno As Long
    Dim wEndno As Long
    Dim wSheetName As String
    Dim wSheetCnt As Long
    Dim wPage As Long
     
    wRow = 3
    wPage = 1
         
    wSheetName = "s" & prmCode
    If chkSheetUmu(wSheetName) = True Then
        Worksheets(wSheetName).Range("A:G").ClearContents 'シートクリア
    End If
     
    'Yahooファイナンス「時系列データ 」ページのHTMLソースを取得
    strURL = "https://finance.yahoo.co.jp/quote/" & prmCode & "/history?"
    strURL = strURL & "from=" & Format(Me.Range("開始日"), "yyyymmdd")
    strURL = strURL & "&to=" & Format(Me.Range("終了日"), "yyyymmdd")
    Select Case Range("期間単位")
        Case "週間"
            strURL = strURL & "&timeFrame=w"
        Case "月間"
            strURL = strURL & "&timeFrame=m"
        Case Else
            strURL = strURL & "&timeFrame=d"
    End Select
    strURL = strURL & "&page="
 
UrlGetTrap:
    'オブジェクト変数に参照セットする
    Set oHttp = CreateObject("MSXML2.XMLHTTP")
     
    With oHttp
        'URL読み込み
        .Open "GET", strURL & wPage, False
        .Send
         
        If (.Status < 200 Or .Status >= 300) Then
            MsgBox "コード:" & prmCode & "のURL読み込みに失敗しました", vbExclamation + vbOKOnly, "Error!"
            GoTo ExitTrap
        End If
         
        If InStr(1, .responseText, "時系列情報がありません") > 0 Then
            GoTo ExitTrap
        End If
 
        If InStr(1, .responseText, "終値") = 0 Then
            MsgBox "コード:" & prmCode & "の時系列データが見つかりません", vbInformation + vbOKOnly
            GoTo ExitTrap
        End If
         
        If wPage = 1 Then
            If chkSheetUmu(wSheetName) = False Then
            'シート作成
                wSheetCnt = Worksheets.Count
                Worksheets.Add after:=Worksheets(wSheetCnt)
                ActiveSheet.Name = wSheetName
                '列幅設定
                With ActiveSheet
                    .Columns(1).ColumnWidth = 14
                    .Columns(2).ColumnWidth = 10
                    .Columns(3).ColumnWidth = 10
                    .Columns(4).ColumnWidth = 10
                    .Columns(5).ColumnWidth = 10
                    .Columns(6).ColumnWidth = 12
                    .Columns(7).ColumnWidth = 10
                End With
            End If
            Me.Hyperlinks.Add Anchor:=Me.Cells(prmListRow, 1), Address:="", SubAddress:="'" & wSheetName & "'!A1"
            Worksheets(wSheetName).Cells(1, 1) = prmCode
             
            'HTMLソースから[銘柄名]取り出し
            strText = GetText(.responseText, "<title>", "【")
            Me.Cells(prmListRow, 2) = strText
            Worksheets(wSheetName).Cells(1, 2) = strText
            Worksheets(wSheetName).Hyperlinks.Add Worksheets(wSheetName).Cells(1, 2), strURL & wPage 'YahooファイナンスWebページをハイパーリンク
                
            '列見出し
            Worksheets(wSheetName).Cells(2, 1) = "日付"
            Worksheets(wSheetName).Cells(2, 2) = "始値"
            Worksheets(wSheetName).Cells(2, 3) = "高値"
            Worksheets(wSheetName).Cells(2, 4) = "安値"
            Worksheets(wSheetName).Cells(2, 5) = "終値"
            Worksheets(wSheetName).Cells(2, 6) = "出来高"
            Worksheets(wSheetName).Cells(2, 7) = "調整後終値"
             
        End If
            
        'HTMLソースから時系列表データ切り出し
        strText = GetText(.responseText, "histories" & Chr(34) & ":[", "paging")
        strText = GetText(strText, "histories" & Chr(34) & ":[", "]},")
         
        '1行区切りごとに配列セット
        arrData = Split(strText, Chr(34) & "},{", , vbTextCompare)
         
        For wIdx1 = LBound(arrData) To UBound(arrData)
            '1行分のデータを列ごとに配列セット
            arrLine = Split(arrData(wIdx1), Chr(34) & "," & Chr(34), , vbTextCompare)
            wClm = 1
            For wIdx2 = LBound(arrLine) To UBound(arrLine)
                strText = arrLine(wIdx2)
                 
                '1項目分のデータから改行(Chr(10))を切り取る
                Do Until InStr(1, strText, Chr(10)) = 0
                    wStrno = InStr(1, strText, Chr(10))
                    strText = Mid(strText, 1, wStrno - 1) & Mid(strText, wStrno + 1, Len(strText) - wStrno)
                Loop
                 
                '1項目分のデータから値のみ切り取る
                wStrno = InStr(1, strText, ":")
                strText = Mid(strText, wStrno + 2, Len(strText) - wStrno + 2)
                 
                'セルへ値セット
                strText = Replace(strText, Chr(34), "")
                strText = Replace(strText, "}", "")
                Select Case wClm
                    Case 1: Worksheets(wSheetName).Cells(wRow, 2) = strText
                    Case 2: Worksheets(wSheetName).Cells(wRow, 3) = strText
                    Case 3: Worksheets(wSheetName).Cells(wRow, 4) = strText
                    Case 4: Worksheets(wSheetName).Cells(wRow, 5) = strText
                    Case 5: Worksheets(wSheetName).Cells(wRow, 6) = strText
                    Case 6: Worksheets(wSheetName).Cells(wRow, 7) = strText
                    Case 7
                        If IsDate(strText) Then
                            Worksheets(wSheetName).Cells(wRow, 1) = CDate(strText)
                        Else
                            Worksheets(wSheetName).Cells(wRow, 1) = strText
                        End If
                End Select
                 
                wClm = wClm + 1
                If wClm > 7 Then
                    Exit For
                End If
            Next
            wRow = wRow + 1
        Next
         
        strText = .responseText
    End With
     
    '次ページのHTMLソースを取得
    wPage = wPage + 1
    GoTo UrlGetTrap
     
ExitTrap:
    '日付順に並び替え
    If Range("順序") = "日付昇順" Then
        If chkSheetUmu(wSheetName) = True Then
            Worksheets(wSheetName).Select
            Worksheets(wSheetName).Cells(3, 1).Select
            Selection.Sort Key1:=Worksheets(wSheetName).Cells(3, 1), Order1:=xlAscending, Header:=xlGuess, _
                OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod:=xlPinYin
        End If
    End If
     
    Me.Activate
     
    'オブジェクト変数を解放する
    Set oHttp = Nothing
     
    Exit Sub
ErrorTrap:
    'エラー処理
    MsgBox "cmdKabukaGet_Click Error!" & Err.Number & ":" & Err.Description, vbExclamation + vbOKOnly, "Error!!"
    Resume ExitTrap
End Sub
 
Public Function GetText(prmAllText As String, prmStrText, prmEndText)
    '全体文字列(prmAllText)の中から開始文字列(prmStrText)〜終了文字列(prmEndText)までの間の文字を取得する
    Dim wStrno As Long
    Dim wEndno As Long
     
    wStrno = InStr(1, prmAllText, prmStrText) + Len(prmStrText) '開始文字列の次の文字位置を取得する
    wEndno = InStr(wStrno, prmAllText, prmEndText) '終了文字列の位置を取得する
    GetText = Mid(prmAllText, wStrno, wEndno - wStrno) '開始文字列〜終了文字列までの間の文字を取得する
End Function
 
Function chkSheetUmu(prmSheetName) As Boolean
    'シートの存在有無チェック
    Dim wSheet As Object
     
    chkSheetUmu = False
     
    For Each wSheet In Sheets
        If LCase(prmSheetName) = LCase(wSheet.Name) Then
            chkSheetUmu = True
            Exit For
        End If
    Next
End Function
 

回答
投稿日時: 21/05/24 20:21:52
投稿者: simple

https://support.yahoo-net.jp/PccFinance/s/article/H000011276
にあるように、これはYahoo!ファイナンスの禁止事項に抵触しますから、やめたほうがよいと思います。

引用:
Yahoo!ファイナンス掲載情報の自動取得(スクレイピング)は禁止しています
 
Yahoo!ファイナンスでは、Yahoo!ファイナンスに掲載している株価やその他の
データを、プログラム等を用いて機械的に取得する行為(スクレイピング等)
について、システムに過度の負荷がかかり、安定したサービス提供に支障をきたす
恐れがあることから禁止しています。
 
また、Yahoo!ファイナンスに掲載する情報の著作権その他一切の権利は、
ヤフー株式会社、情報提供者またはその他の権利者に帰属します。
当該掲載情報の転用、複製および外部配信ならびに販売を含む商用利用等の一切を
固く禁じています。
 
株価データのダウンロードを利用したい場合は、「VIP倶楽部」の「時系列データダウンロード」をご利用ください。
なお、こちらの掲示板は作業依頼を受け付けるところではありませんので
誤解されないようお願いします。
 
# ちなみに、
# > 以前作って頂いたマクロに
# とのことですが、勘違いしていませんか?
# そういう事実はないと思います。
放置されているスレッドについても対応をお願いします。

投稿日時: 21/05/25 13:24:52
投稿者: tommy6

ご教授ありがとうございます。