IPO全盛期を過ぎた2007年ごろに投資資金50万ではじめました。現在はIPO、PO、優待、他などローリスク投資が中心の取引を行っています。

2017/09123456789101112131415161718192021222324252627282930312017/11

にほんブログ村 株ブログ IPO・新規公開株へ      にほんブログ村 株ブログ PO・公募増資株へ      にほんブログ村 株ブログ 株主優待へ

上記の広告は1ヶ月以上更新のないブログに表示されています。
新しい記事を書く事で広告が消せます。

3月優待取りが近づいてきましたね~。
毎回、3月、9月は優待情報をいろんなところからかき集めてきて、優待リストを作って
と大変な作業だったので、なんとか自動化できないかとエクセルで自動取得できるマクロ
を試行錯誤して作ってました。

一番難関だったのが、優待内容を自動的に取得するところだったのですが、なんとか
できるようになりました。

基本的にはホームページから優待リストに必要な情報をとってきて、エクセルに貼りつける
マクロです。このようにホームページから必要な情報をぬきだすことをスクレイピングというそうです。

マクロを公開しておきますので、興味のある方はどうぞ、お気軽に質問ください。


ポチっとお願いします。
 ↓
にほんブログ村 株ブログ IPO・新規公開株へ

Sub cmdKabukaGet_Click()
    On Error GoTo ErrorTrap
    Dim oHttp       As Object
    Dim strURL      As String
    Dim strText     As String
    Dim strTable    As String
    Dim wRow        As Long
    Dim wArr()      As String
    Dim aryData(1 To 9999, 1 To 20)
    Dim re
    Set re = CreateObject("VBScript.RegExp")

    '更新確認メッセージ
    If MsgBox("株価を更新します。よろしいですか?", vbQuestion + vbOKCancel, "確認") <> vbOK Then
        GoTo ExitTrap
    End If
   
    'マウスポインタを砂時計にする
    Application.Cursor = xlWait
   
    'オブジェクト変数に参照セットする
    Set oHttp = CreateObject("MSXML2.XMLHTTP")

    'A列の2行目から最終行まで処理を繰り返す
    For wRow = 2 To Range("A" & Rows.Count).End(xlUp).Row
        If (Cells(wRow, 1) >= 1000 And Cells(wRow, 1) <= 9999) Or Cells(wRow, 1) = 998407 Then 'コード欄に4桁の数値又は998407(日経平均)が入力されているかどうか判断
            With oHttp
                'Yahooファイナンス「チャート」ページのHTMLソースを取得
                strURL = "
http://stocks.finance.yahoo.co.jp/stocks/detail/?code=" & Cells(wRow, 1)
                .Open "GET", strURL, False
                .setRequestHeader "If-Modified-Since", "Thu, 01 Jun 1970 00:00:00 GMT"
                .Send
       
                If (.Status < 200 Or .Status >= 300) Then
                    MsgBox "URL読み込みに失敗しました", vbExclamation + vbOKOnly, "Error!"
                    GoTo ExitTrap
                End If

                'HTMLソースから情報を切り出し
                If InStr(1, .responseText, "現在値") > 0 Then   'コードが一致した株価情報があったかどうか判断
                    Cells(wRow, 1).Select

'全テキストを格納(デバッグでテキストの内容を確認するため)
'strText = .responseText
'Cells(wRow, 16) = strText

                    '【銘柄名】 取得
                    strText = GetText(.responseText, "<title>", "【")
                    Cells(wRow, 2) = strText
                    ActiveSheet.Hyperlinks.Add Cells(wRow, 2), strURL  'YahooファイナンスWebページをハイパーリンク
                   
                    '【市場】 取得
                    strText = ""
                    If InStr(1, .responseText, "市場:", vbTextCompare) > 0 Then
                        strText = GetText(.responseText, "市場:", "</span>")
                        If strText = "" Then
'                            strText = GetText(.responseText, "市場:", "</option>")
                            strText = "複数市場"
                        End If
                    End If
                    Cells(wRow, 3) = strText
                   
                    '【単元株数】 取得
                    strText = ""
                    If InStr(1, .responseText, "単元株数", vbTextCompare) > 0 Then
                        strText = GetValue(.responseText, "単元株数")
                        If Left(strText, 3) = "---" Then
                            strText = 1
                        End If
                    End If
                    Cells(wRow, 4) = strText
                    Cells(wRow, 4).NumberFormat = "#,##0"
                   
                    '【取引値】 取得
                    strText = ""
                    If InStr(1, .responseText, "現在値", vbTextCompare) > 0 Then
                        strText = GetText(.responseText, "現在値<strong>", "yjL")
                        strText = GetText(strText, "yjFL"">", "</span>")
                    End If
                    Cells(wRow, 5) = strText
                    Cells(wRow, 5).NumberFormat = "#,##0"
                                       
                    '【前日差】 取得
                    strText = ""
                    If InStr(1, .responseText, "前日比", vbTextCompare) > 0 Then
                        strText = GetText(.responseText, "前日比</span>", "</td>")
                        If InStr(1, strText, "greenFin", vbTextCompare) > 0 Then
                            strText = GetText(strText, "greenFin"">", "</strong>")
                        ElseIf InStr(1, strText, "redFin", vbTextCompare) > 0 Then
                            strText = GetText(strText, "redFin"">", "</strong>")
                        Else
                            strText = GetText(strText, "<strong>", "</strong>")
                        End If
                    End If
                    If IsNumeric(strText) = False Then
                        strText = 0
                    End If
                    Cells(wRow, 6) = strText
                    Cells(wRow, 6).NumberFormat = "+#,##0;[red]-#,##0;0"
                                       
                    '【前日比】 取得
                    strText = ""
                    If InStr(1, .responseText, "前日比", vbTextCompare) > 0 Then
                        strText = GetText(.responseText, "前日比</span>", "</td>")
                        If InStr(1, strText, "greenFin", vbTextCompare) > 0 Then
                            strText = GetText(strText, "(<strong class=""greenFin"">", "</strong>")
                        ElseIf InStr(1, strText, "redFin", vbTextCompare) > 0 Then
                            strText = GetText(strText, "(<strong class=""redFin"">", "</strong>")
                        Else
                            strText = GetText(strText, "<strong>", "</strong>")
                        End If
                    End If
                    If IsNumeric(strText) = False Then
                        strText = 0
                    End If
                    Cells(wRow, 7) = strText
                    Cells(wRow, 7).NumberFormat = "+0.00;[red]-0.00;0.00"
                   
                    '【出来高】 取得
                    strText = ""
                    If InStr(1, .responseText, ">出来高", vbTextCompare) > 0 Then
                        strText = GetValue(.responseText, ">出来高")
                        If IsNumeric(strText) = False Then
                            strText = "---"
                        End If
                    End If
                    Cells(wRow, 8) = strText
                    Cells(wRow, 8).NumberFormat = "#,##0"
                   
                    '【始値】 取得
                    strText = GetValue(.responseText, "始値")
                    If IsNumeric(strText) = False Then
                        strText = 0
                    End If
                    Cells(wRow, 9) = strText
                    Cells(wRow, 9).NumberFormat = "#,##0"
                   
                    '【高値】 取得
                    strText = GetValue(.responseText, ">高値")
                    If IsNumeric(strText) = False Then
                        strText = 0
                    End If
                    Cells(wRow, 10) = strText
                    Cells(wRow, 10).NumberFormat = "#,##0"
                   
                    '【安値】 取得
                    strText = GetValue(.responseText, ">安値")
                    If IsNumeric(strText) = False Then
                        strText = 0
                    End If
                    Cells(wRow, 11) = strText
                    Cells(wRow, 11).NumberFormat = "#,##0"
                                  
                    '【日付/時刻】 取得
                    strText = GetText(.responseText, "現在値<strong>(", ")</strong>")
                    If InStr(1, strText, "/") > 0 Then
                        Cells(wRow, 12) = strText
                        Cells(wRow, 13) = Null
                    ElseIf InStr(1, strText, ":") > 0 Then
                        Cells(wRow, 12) = Date
                        Cells(wRow, 13) = strText
                    Else
                        Cells(wRow, 12) = Null
                        Cells(wRow, 13) = Null
                    End If
                    Cells(wRow, 12).NumberFormat = "m/d"
                
                    '【分割情報】 取得
                    strURL = "
http://biz.yahoo.co.jp/stockholder/search?detail=" & Cells(wRow, 1)
                    .Open "GET", strURL, False
                    .Send
                    If (.Status < 200 Or .Status >= 300) Then
                        MsgBox "URL読み込みに失敗しました", vbExclamation + vbOKOnly, "Error!"
                        GoTo ExitTrap
                    End If
                    strText = ""
                    If InStr(1, .responseText, "分割情報</th>", vbTextCompare) > 0 Then
                        strText = GetText(.responseText, "分割情報</th>", "</table>")
                        wArr = Split(strText, "<li>", , vbTextCompare)
                        strText = wArr(UBound(wArr))
                        strText = GetTagCut(strText)
                    End If
                    Cells(wRow, 14) = strText

                    '【優待の内容】 取得
                    strURL = "
http://biz.yahoo.co.jp/stockholder/search?detail=" & Cells(wRow, 1)
                    .Open "GET", strURL, False
                    .Send
                    If (.Status < 200 Or .Status >= 300) Then
                        MsgBox "URL読み込みに失敗しました", vbExclamation + vbOKOnly, "Error!"
                        GoTo ExitTrap
                    End If
                    strText = ""
                    If InStr(1, .responseText, "<!-- - contents html START --->", vbTextCompare) > 0 Then
                        ' テーブル抜き出し
                        strTable = GetText(.responseText, "<!-- - contents html START --->", "<!-- - contents html END --->")

                        ' テーブル分解
                        re.IgnoreCase = True
                        re.Global = True
                        strText = re.Replace(strTable, "")

                        re.Pattern = "<.*?>"
                        strText = re.Replace(strText, " ")

                        re.Pattern = "&nbsp;"
                        strText = re.Replace(strText, " ")

                        re.Pattern = "[\s*\n\s*]{2,}"
                        strText = re.Replace(strText, vbCrLf)
                    End If
                    Cells(wRow, 15) = strText
               End If
            End With
        End If
    Next
ExitTrap:
    'マウスポインタを通常に戻す
    Application.Cursor = xlDefault
   
    'オブジェクト変数を解放する
    Set oHttp = Nothing
   
    Exit Sub
ErrorTrap:
    'エラー処理
    MsgBox "cmdKabukaGet_Click Error!" & Err.Number & ":" & Err.Description, vbExclamation + vbOKOnly, "Error!!"
    Resume ExitTrap
End Sub

スポンサーサイト
コメント
この記事へのコメント
コメントを投稿する
URL:
Comment:
Pass:
秘密: 管理者にだけ表示を許可する
 
トラックバック
この記事のトラックバックURL
http://horizontalgrays.blog19.fc2.com/tb.php/101-5d69ebd1
この記事にトラックバックする(FC2ブログユーザー)
この記事へのトラックバック
上記広告は1ヶ月以上更新のないブログに表示されています。新しい記事を書くことで広告を消せます。