株取引に VBA を使う(シストレツール)

Option Explicit
Option Base 1

   Dim データ配列() As Variant
   Dim 最終行数 As Integer
   Dim 処理行 As Integer
   Dim 対象URL As String
   Dim 日経URL As String
   Dim IEバージョン As String
   Dim IEオブジェクト As Object
   Dim 入力行 As Integer
   Dim 処理 As String
   Dim Shellオブジェクト As Object
   Dim 前回最終行 As Integer
   Dim HTMLソース As String
   Dim HTMLタイトル As String
   Dim 開始時刻 As Variant
   Dim 終了時刻 As Variant


Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
'これで Sleepを使ってミリ秒単位で処理にウェイトを入れることができます。


Sub 日経会社情報で株価を取得する()

   開始時刻 = Now() 'マクロの処理時間を計測するため、開始時刻を取得

   ThisWorkbook.Worksheets("スタート").Activate

   'シート「スタート」の登録内容を、証券コード順に並び替え
   Range("A1").CurrentRegion.Sort _
      Key1:=Range("A1"), Order1:=xlAscending, _
      Header:=xlYes

   Call IEバージョンを調べる() 'IEのバージョンによって処理が変わるため

   'インターネット画面表示するためのデータを格納
   データ配列 = Range("A1").CurrentRegion.Value
   最終行数 = UBound(データ配列)
   日経URL = Range("G11").Value

   ThisWorkbook.Worksheets("取得株価").Activate
   前回最終行 = Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row

   '前回取得時の内容を削除
   If 前回最終行 > 1 Then
      Rows("2:" & CStr(前回最終行)).Delete Shift:=xlUp
   End If

   '証券コード毎に、インターネットから情報を取得
   For 処理行 = 2 To 最終行数

      'Shell.Applicationオブジェクトの作成
      Set Shellオブジェクト = CreateObject("Shell.Application")
      'IEオブジェクトの作成(ダミー)
      Set IEオブジェクト = CreateObject("InternetExplorer.Application")
      対象URL = 日経URL & データ配列(処理行, 1)

      If IEバージョン > "6" Then
         IEオブジェクト.Navigate2 対象URL     '★IE7の場合、既存or新しいウィンドウで表示される
         If 入力行 = 1 Then
            IEオブジェクト.Quit               '★IE7の場合、ここで閉じるのはCreateObjectで作成したウィンドウ
            Set IEオブジェクト = Nothing      '★IE7の場合、いったんオブジェクトをクリア
            Application.Wait Now + TimeValue("00:00:01")
         End If

         処理 = "Shell.ApplicationオブジェクトのWindowオブジェクトからIEオブジェクトを取り出す"
         '作成されているポイントは、Windowsコレクションの最後の要素

         Set IEオブジェクト = Shellオブジェクト.Windows.Item(Shellオブジェクト.Windows.Count - 1)
         'これ以降は、従来と同様の方法で操作が可能
         With IEオブジェクト
            .Navigate 対象URL
            .Visible = True
         End With

         Call IE表示待ち

      Else
         '★IE6以前の場合
         Set IEオブジェクト = CreateObject("InternetExplorer.Application")

         With IEオブジェクト
            .Navigate 対象URL
            .Visible = True
         End With

         Call IE表示待ち

      End If

      HTMLタイトル = ""
      HTMLソース = ""

      Do While HTMLソース = ""
         Sleep (1000)
         HTMLソース = IEオブジェクト.Document.Body.InnerHtml
      Loop

      HTMLタイトル = IEオブジェクト.LocationName

      Call 株価を取得してシートに貼付け 'ブラウザの画面から必要な項目を抽出して貼付けする

      IEオブジェクト.Quit

   Next 処理行

   'オブジェクトを破棄
   Set IEオブジェクト = Nothing

   'マクロの処理時間を表示して、マクロの終了を伝える
   終了時刻 = Now()
   MsgBox "処理が終了しました。" & Chr(13) _
   & "処理時間は、" & Format(終了時刻 - 開始時刻, "nn分ss秒") & " でした。", vbOKOnly

End Sub


Private Sub 株価を取得してシートに貼付け()
   Dim 文字配列
   Dim ページ行数 As Integer
   Dim 行文字列 As String
   Dim 行数 As Integer
   Dim 行カウンタ As Integer

   If Left(HTMLタイトル, 2) = "()" Then '証券コードのデータが存在しない場合
      Range("A1").Cells(処理行, 1).Value = データ配列(処理行, 1)
      Range("B1").Cells(処理行, 1).Value = "★証券コードの企業が存在しません★"

   Else '証券コードのデータが存在した場合
      Range("A1").Cells(処理行, 1).Value = データ配列(処理行, 1)
      Range("B1").Cells(処理行, 1).Value = Trim(Mid(HTMLタイトル, 5, InStr(HTMLタイトル, "：") - 5))

      'ブラウザに表示されている内容を、1行ずつに分割
      文字配列 = Split(HTMLソース, vbNewLine)

      '全体行数を取得
      ページ行数 = UBound(文字配列)

      '取得行の絞込みに使うパラメータを初期化
      行カウンタ = 1

      '1行目から順に、最後の行まで
      For 行数 = 200 To ページ行数
         行文字列 = 文字配列(行数)

         'HTML から必要な項目を抽出するためのコーディングの情報を取得
         Debug.Print 行数
         Debug.Print 行文字列 'HTMLの内容を、イミディエイト・ウインドウに表示する

         If 行カウンタ = 1 Then
            If InStr(行文字列, "全上場企業データベース") = 0 Then
               GoTo 次の行へ '「全上場企業データベース」の行に到達するまで読み飛ばす
            Else
               行カウンタ = 行数
            End If
         End If

         If InStr(行文字列, "DD class=stc-now") > 0 And 行数 > 行カウンタ Then   '現在値
            行カウンタ = 行数
            Range("C1").Cells(処理行, 1).Value = Trim(正規表現で置換("<(.*?)>", 行文字列, ""))

         ElseIf (InStr(行文字列, "SPAN class=cmn-plus") > 0 Or InStr(行文字列, "SPAN class=cmn-minus") > 0 _
            Or InStr(行文字列, "SPAN class=stc-percent") > 0) _
            And 行数 > 行カウンタ Then    '前日比金額 前日比%

            行カウンタ = 行数
            Range("H1").Cells(処理行, 1).Value _
            = Left(正規表現で置換("<(.*?)>", 行文字列, ""), InStr(正規表現で置換("<(.*?)>", 行文字列, ""), "(") - 1)
            Range("I1").Cells(処理行, 1).Value _
            = Mid(Trim(正規表現で置換("<(.*?)>", 行文字列, "")) _
            , InStr(Trim(正規表現で置換("<(.*?)>", 行文字列, "")), "(") + 1 _
            , Len(Trim(正規表現で置換("<(.*?)>", 行文字列, ""))) - InStr(Trim(正規表現で置換("<(.*?)>", 行文字列, "")), "(") - 1)

         ElseIf InStr(行文字列, "DD class=stc-opening") > 0 And 行数 > 行カウンタ Then     '始値
            行カウンタ = 行数
            Range("J1").Cells(処理行, 1).Value = Trim(正規表現で置換("<(.*?)>", 行文字列, ""))

         ElseIf InStr(行文字列, "DD class=stc-high") > 0 And 行数 > 行カウンタ Then      '高値
            行カウンタ = 行数
            Range("K1").Cells(処理行, 1).Value = Trim(正規表現で置換("<(.*?)>", 行文字列, ""))

         ElseIf InStr(行文字列, "DD class=stc-low") > 0 And 行数 > 行カウンタ Then    '安値
            行カウンタ = 行数
            Range("L1").Cells(処理行, 1).Value = Trim(正規表現で置換("<(.*?)>", 行文字列, ""))

         ElseIf InStr(行文字列, "DD class=stc-sales") > 0 And 行数 > 行カウンタ Then        '売買高
            行カウンタ = 行数
            Range("M1").Cells(処理行, 1).Value = Trim(正規表現で置換("<(.*?)>", 行文字列, ""))

         ElseIf InStr(行文字列, "DD class=stc-pbr") > 0 And 行数 > 行カウンタ Then        'PBR (実績)
            行カウンタ = 行数
            Range("N1").Cells(処理行, 1).Value = Trim(正規表現で置換("<(.*?)>", 行文字列, ""))

         ElseIf InStr(行文字列, "DD class=stc-per") > 0 And 行数 > 行カウンタ Then        'PER (予想)
            行カウンタ = 行数
            Range("O1").Cells(処理行, 1).Value = Trim(正規表現で置換("<(.*?)>", 行文字列, ""))

         ElseIf InStr(行文字列, "cmnc-middle") > 0 And 行数 > 行カウンタ Then        '関連ニュース
            行カウンタ = 行数
            Range("E1").Cells(処理行, 1).Value = Trim(正規表現で置換("<(.*?)>", 行文字列, ""))

         ElseIf InStr(行文字列, "年初来高値") > 0 And 行数 > 行カウンタ Then        '年初来高値
            行カウンタ = 行数
            行数 = 行数 + 1
            行文字列 = 文字配列(行数)
            Debug.Print 行数
            Debug.Print 行文字列
            Range("P1").Cells(処理行, 1).Value = Trim(正規表現で置換("<(.*?)>", 行文字列, ""))

         ElseIf InStr(行文字列, "年初来安値") > 0 And 行数 > 行カウンタ Then        '年初来安値
            行カウンタ = 行数
            行数 = 行数 + 1
            行文字列 = 文字配列(行数)
            Debug.Print 行数
            Debug.Print 行文字列
            Range("Q1").Cells(処理行, 1).Value = Trim(正規表現で置換("<(.*?)>", 行文字列, ""))

         ElseIf InStr(行文字列, "10年来高値") > 0 And 行数 > 行カウンタ Then     '10年来高値
            行カウンタ = 行数
            行数 = 行数 + 1
            行文字列 = 文字配列(行数)
            Debug.Print 行数
            Debug.Print 行文字列

            Range("R1").Cells(処理行, 1).Value = Trim(正規表現で置換("<(.*?)>", 行文字列, ""))

         ElseIf InStr(行文字列, "10年来安値") > 0 And 行数 > 行カウンタ Then     '10年来安値

            行数 = 行数 + 1
            行文字列 = 文字配列(行数)
            Debug.Print 行数
            Debug.Print 行文字列

            Range("S1").Cells(処理行, 1).Value = Trim(正規表現で置換("<(.*?)>", 行文字列, ""))
            Exit For
         End If
次の行へ:
      Next 行数 'html の Body データを一行ごとに読む


      'コメント部分を表示
      If データ配列(処理行, 2) <> "" Then '保有株
         Range("F1").Cells(処理行, 1).Value = データ配列(処理行, 2) '購入単価
         Range("G1").Cells(処理行, 1).Value = _
         Range("C1").Cells(処理行, 1).Value / Range("F1").Cells(処理行, 1).Value * 100 - 100

         If データ配列(処理行, 3) <> "" Then '利食い率
            If Range("C1").Cells(処理行, 1).Value > Range("F1").Cells(処理行, 1).Value * (1 + データ配列(処理行, 3) / 100) Then
               Range("D1").Cells(処理行, 1).Value = "売り"
               Range("D1").Cells(処理行, 1).Interior.ColorIndex = 4
            End If
         End If

         If データ配列(処理行, 4) <> "" Then '損切り率
            If Range("C1").Cells(処理行, 1).Value < Range("F1").Cells(処理行, 1).Value * (1 - データ配列(処理行, 4) / 100) Then
               Range("D1").Cells(処理行, 1).Value = "売り"
               Range("D1").Cells(処理行, 1).Interior.ColorIndex = 3
            End If
         End If

      End If
      '年初来安値との比較
      If Range("C1").Cells(処理行, 1).Value < Val(Range("Q1").Cells(処理行, 1).Value) * 1.05 Then
         Range("D1").Cells(処理行, 1).Value = "買い"
         Range("D1").Cells(処理行, 1).Interior.ColorIndex = 8
      End If
      '前日比マイナスを赤に
      If Val(Range("I1").Cells(処理行, 1).Value) < -0.01 Then
         Range("I1").Cells(処理行, 1).Interior.ColorIndex = 7
      End If
   End If

End Sub


Private Sub IE表示待ち()

   DoEvents       ' Sleep しているときに、画面を書き換えできるように、OS に制御を渡す。

   Do While IEオブジェクト.Busy = True Or IEオブジェクト.readystate <> 4
      Sleep (1000)
   Loop
   Sleep (2000)

End Sub

Option Explicit
Option Base 1

   Dim XMLHTTPオブジェクト As Object
   Dim URL株式株価Yahooファイナンス As String


Sub 時系列株価を取得()

   Dim HTMLタイトル As String
   Dim 正規表現タイトル As RegExp
   Dim Matchesコレクション As Object

   Dim 銘柄コード As String
   Dim SaveFolder As String
   Dim 取得ページ数 As Integer
   Dim ファイルシステムオブジェクト As Object
   Dim 出力ファイルパス As String
   Dim キストストリームオブジェクト As Object
   Dim 正規表現 As RegExp
   Dim 取得ページカウンタ As Integer
   Dim HTMLソース As String

   Dim カウンタ As Integer
   Dim 開始日時 As Variant
   Dim 終了日時 As Variant
   Dim 追加シート名初期 As String
   Dim 追加シート名 As String
   Dim 重複 As Integer
   Dim シート As Worksheet
   Dim シート数 As Integer

   Dim 列数 As Integer
   Dim 行数 As Integer
   Dim 文字列 As String
   Dim 銘柄配列() As Variant
   Dim 最終行 As Integer
   Dim 銘柄数 As Integer
   Dim 銘柄カウンタ As Integer

   '時系列株価を取得し、Excelシートに書き出すツールです。

   開始日時 = Now                ' 開始時刻を変数に格納します。
   
   ' 処理を高速化するため、自動計算停止
   Application.Calculation = xlCalculationManual

   '前回作成したシートがあれば削除
   For Each シート In ThisWorkbook.Worksheets
      If シート.Name <> "テンプレート" And シート.Name <> "指定登録" Then
         'シート名 テンプレート と 指定登録 以外のシートを削除
         Application.DisplayAlerts = False
         シート.Delete
         Application.DisplayAlerts = True
      End If
   Next シート
   
   ThisWorkbook.Worksheets("指定登録").Activate
   URL株式株価Yahooファイナンス = Range("B1").Value
   取得ページ数 = Int(Range("B2").Value / 20 + 0.99)
   最終行 = Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row
   銘柄数 = 最終行 - 5
   銘柄配列 = Range("A6").Resize(銘柄数, 1)
   SaveFolder = Range("B3").Value

   '以上が設定です。ここより下の行はメインプログラムとなります。
   
   Set ファイルシステムオブジェクト = CreateObject("Scripting.FileSystemObject")
   
   If Dir(ソース保存フォルダ, vbDirectory) = "" Then 'この名前のフォルダが存在しなければ
      MkDir ソース保存フォルダ
   End If


   Set 正規表現 = New RegExp
   正規表現.Pattern = "(\d{4}年\d{1,2}月\d{1,2}日)</td><td>([\.0-9|,]+)</td><td>([\.0-9|,]+)</td><td>([\.0-9|,]+)</td><td>([\.0-9|,]+)</td><td>([\.0-9|,]+)</td><td>([\.0-9|,]+)"
   正規表現.Global = True

   'HTML のタイトル抽出用
   Set 正規表現タイトル = New RegExp
   With 正規表現タイトル
      .Pattern = "<title>.*</title>"
      .IgnoreCase = True '大文字小文字を区分しない
      .Global = False
   End With

   For 銘柄カウンタ = 1 To 銘柄数
   
      '株価コードを設定します
      銘柄コード = 銘柄配列(銘柄カウンタ, 1)
   
      出力ファイルパス = ファイルシステムオブジェクト.buildPath(SaveFolder, 銘柄コード & ".txt")
      '構文：object.CreateTextFile(filename[, overwrite[, unicode]]) → ShiftJIS だとエラーになる文字があるため↓
      'http://blog.systemjp.net/entry/2013/04/10/191821 ←教えていただいたサイト
      'http://ameblo.jp/cashtray/entry-11066671774.html ←教えていただいたサイト
      Set キストストリームオブジェクト = ファイルシステムオブジェクト.CreateTextFile(出力ファイルパス, True, True)

      追加シート名初期 = 銘柄コード
      追加シート名 = 追加シート名初期
   
      For 重複 = 1 To 100
      ' 100枚まで追加しても重複しないように追番を設定します。
          For Each シート In Worksheets
              If シート.Name = 追加シート名 Then
                  追加シート名 = 追加シート名初期 & "(" & 重複 & ")"
              End If
          Next シート
      Next 重複
      シート数 = Worksheets.Count
      Worksheets("テンプレート").Copy After:=Worksheets(シート数)
      ActiveSheet.Name = 追加シート名
      
      行数 = 0
      For 取得ページカウンタ = 1 To 取得ページ数
         HTMLソース = HTML取得(URL結合(銘柄コード, Date - 80 * 取得ページカウンタ, Date, 取得ページカウンタ))
          
         Range("A2").Value = URL結合(銘柄コード, Date - 80 * 取得ページカウンタ, Date, 取得ページカウンタ)


         '検証用にHTMLソースを出力
         キストストリームオブジェクト.writeLine HTMLソース

         'HTML のタイトル抽出
         Set Matchesコレクション = 正規表現タイトル.Execute(HTMLソース)
         文字列 = Matchesコレクション(0).Value
         HTMLタイトル = Trim(正規表現で置換("<(.*?)>", 文字列, ""))
            
         If InStr(HTMLタイトル, "：") > 0 Then
            Range("A1").Value = Trim(Left(HTMLタイトル, InStr(HTMLタイトル, "：") - 1))
         Else
            Range("A1").Value = HTMLタイトル
         End If

         '1行目から順に、最後の行まで
      
         Set Matchesコレクション = 正規表現.Execute(HTMLソース)
         For カウンタ = 0 To Matchesコレクション.Count - 1
            行数 = 行数 + 1
            For 列数 = 1 To 7
               Range("A4").Cells(行数, 列数).Value = Matchesコレクション(カウンタ).SubMatches(列数 - 1)
            Next 列数
         Next カウンタ

      Next 取得ページカウンタ
      
      キストストリームオブジェクト.Close
   
   Next 銘柄カウンタ
   
   ' 自動計算停止解除
   Application.Calculation = xlCalculationAutomatic
    
   終了日時 = Now
   MsgBox "処理時間は、" _
   & Format(終了日時 - 開始日時, "hh時間nn分ss秒") & " でした。"

End Sub


Function URL結合(code, s_date, e_date, p_cnt)
'時系列データ取得元サイトのURLを作成する関数
    URL結合 = URL株式株価Yahooファイナンス
    URL結合 = URL結合 & "?code=" & code & ".T"
    URL結合 = URL結合 & "&sy=" & Year(s_date)
    URL結合 = URL結合 & "&sm=" & Month(s_date)
    URL結合 = URL結合 & "&sd=" & Day(s_date)
    URL結合 = URL結合 & "&ey=" & Year(e_date)
    URL結合 = URL結合 & "&em=" & Month(e_date)
    URL結合 = URL結合 & "&ed=" & Day(e_date)
    URL結合 = URL結合 & "&tm=d"
    URL結合 = URL結合 & "&p=" & p_cnt
    
End Function


Function HTML取得(url)
'URLからHTMLを取得する関数
   Set XMLHTTPオブジェクト = CreateObject("MSXML2.XMLHTTP")
'    On Error Resume Next
   Call XMLHTTPオブジェクト.Open("GET", url, False)
   Call XMLHTTPオブジェクト.send
   'https://infith.com/system/access/vba_xmlhttp/
   'https://www.javadrive.jp/javascript/ajax/index1.html
   '「open」メソッドはサーバに対するHTTPリクエストを作成します。
   '1 番目の引数は、リクエストが「GET」か「POST」かを指定します。(必須)
   '2 番目の引数は、リクエストを送るURLを指定します。 (必須)
   '3 番目の引数は、非同期通信か同期通信かを指定します。
   '　同期通信の場合は「false」を、非同期通信の場合は「true」を指定します。省略した場合は「true」が設定されます。
   '　同期通信にした場合はサーバに対するリクエストからの応答があるまで待ってから次の処理へ進みます。
   '　その為、処理が移った時点では既に応答が帰ってきていますので、その応答に対する処理を記述するだけで記述は簡単になります。
   '　その代わり応答が帰ってくるまでブラウザは他の処理を行えません。
   '　非同期通信にした場合にはリクエストを送った時点で次の処理へ進みます。
   '　その為、リクエストを送信したブラウザではすぐに他の処理を行えますが、
   '　今度は応答に対する処理を行うには、応答が帰ってきたのかどうかを別途調べる処理が必要となります。

   HTML取得 = XMLHTTPオブジェクト.responseText

'    On Error GoTo 0
End Function

Sub test2()
    Dim str As String
    str = "2014/02/22 12:34:56"
    
    Dim regex As Object
    Set regex = CreateObject("VBScript.RegExp")
    regex.Pattern = "(\d+)/(\d+)/(\d+) (\d+):(\d+):(\d+)"
    regex.Global = True
     
    Dim result As Object
    Dim i As Integer
    Set result = regex.Execute(str)
    'Executeメソッドで文字列マッチを実行すると、結果はMatchesコレクションとして返されます
    'result.Countで Match オブジェクトの個数を判定します。
    If result.Count > 0 Then

        'result(0)に対して SubMatches コレクションを取得します。
        For i = 0 To result(0).SubMatches.Count - 1
           MsgBox result(0).SubMatches(i)
          'SubMatchesコレクションには個別のサブマッチ文字列が格納されています
        Next
    End If
 
    Set regex = Nothing
End Sub

Option Explicit
Option Base 1

'01：2015/09/03：作成
'02：2015/09/10：指定日が一週間以内の場合、セル背景色を赤に。2週間以内の場合は黄色に。
'03：2015/09/12：銘柄シートへのリンク追加。

   Dim XMLHTTPオブジェクト As Object
   Dim URL株式株価Yahooファイナンス As String
   Dim 文字列 As String

Sub 日々公表銘柄の時系列株価を取得()

   Dim 開始日時 As Variant
   Dim 終了日時 As Variant
   
   開始日時 = Now                ' 開始時刻を変数に格納します。
   
   ' 処理を高速化するため、自動計算停止
   Application.Calculation = xlCalculationManual
   
   Call SBI証券の注意銘柄から日々公表銘柄を取得
   Call 時系列株価を取得
   
   ThisWorkbook.Worksheets("指定登録").Activate
   
   ' 自動計算停止解除
   Application.Calculation = xlCalculationAutomatic
    
   終了日時 = Now
   MsgBox "処理時間は、" _
   & Format(終了日時 - 開始日時, "hh時間nn分ss秒") & " でした。"
   
End Sub


Private Sub SBI証券の注意銘柄から日々公表銘柄を取得()

   Dim URL注意銘柄 As String
   Dim Matchesコレクション As Object
   Dim ファイルシステムオブジェクト As Object
   Dim 出力ファイルパス As String
   Dim キストストリームオブジェクト As Object
   Dim ソース保存フォルダ As String
   Dim 正規表現 As RegExp
   Dim HTMLソース As String
   Dim カウンタ As Integer
   Dim 最終行 As Integer
   Dim 日付 As Date
   Dim 銘柄コード As String
   Dim 銘柄名 As String
   
   ThisWorkbook.Worksheets("指定登録").Activate
   URL注意銘柄 = Range("B4").Value
   ソース保存フォルダ = Range("B3").Value
   
   '前回の取得銘柄のデータを削除
   最終行 = Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row
   Range("A6:C" & CStr(最終行)).Delete Shift:=xlUp
   
   Set ファイルシステムオブジェクト = CreateObject("Scripting.FileSystemObject")
   
   If Dir(ソース保存フォルダ, vbDirectory) = "" Then 'この名前のフォルダが存在しなければ
      MkDir ソース保存フォルダ
   End If
   
   Set 正規表現 = New RegExp
   
   '<td class="mtext">(.+?)</td><td align="center" class="mtext">([0-9]{4})</td><td class="mtext">東証</td><td class="mtext">日々公表（(.+?)）</td>
   'VBAコードの文字定数(引用符「"」で囲まれた文字列)の中に引用符を入れたいときは、「"」を 2重にします。
   正規表現.Pattern = "<td class=""mtext"">(.+?)</td><td align=""center"" class=""mtext"">([0-9]{4})</td><td class=""mtext"">東証</td><td class=""mtext"">日々公表（(.+?)）</td>"
   
   正規表現.Global = True
   
   出力ファイルパス = ファイルシステムオブジェクト.buildPath(ソース保存フォルダ, "注意銘柄.txt")
   '構文：object.CreateTextFile(filename[, overwrite[, unicode]]) → ShiftJIS だとエラーになる文字があるため↓
   'http://blog.systemjp.net/entry/2013/04/10/191821 ←教えていただいたサイト
   'http://ameblo.jp/cashtray/entry-11066671774.html ←教えていただいたサイト
   Set キストストリームオブジェクト = ファイルシステムオブジェクト.CreateTextFile(出力ファイルパス, True, True)
   
   'WEB ページが Shift_JIS のためUNICODEに変換して取得
   HTMLソース = HTML取得ShiftJIS2UNICODE(URL注意銘柄)
   
   '正規表現でマッチングするために過剰な改行を外す。
   HTMLソース = Replace(HTMLソース, vbNewLine, "") 'Windowsのサーバ用
   HTMLソース = Replace(HTMLソース, vbLf, "")      'UNIXのサーバ用
   
   '表の行単位にするために、表の行末に改行を挿入
   HTMLソース = Replace(HTMLソース, "</tr>", "</tr>" & vbNewLine)
   '見やすくするために、</head>の後に改行を入れる
   HTMLソース = Replace(HTMLソース, "</head>", "</head>" & vbNewLine)
   
   '検証用にHTMLソースを出力
   キストストリームオブジェクト.writeLine HTMLソース
   
   Set Matchesコレクション = 正規表現.Execute(HTMLソース)
   
   '1つめのマッチから順に、最後のマッチまで
   For カウンタ = 0 To Matchesコレクション.Count - 1
   
      銘柄コード = Matchesコレクション(カウンタ).SubMatches(1)
      ActiveSheet.Hyperlinks.Add Anchor:=Range("A6").Cells(カウンタ + 1, 1), Address:="", _
      SubAddress:="'" & 銘柄コード & "'!A1", TextToDisplay:=銘柄コード
      
      銘柄名 = Matchesコレクション.Item(カウンタ).SubMatches(0)
      ActiveSheet.Hyperlinks.Add Anchor:=Range("B6").Cells(カウンタ + 1, 1), Address:="", _
      SubAddress:="'" & 銘柄コード & "'!A1", TextToDisplay:=銘柄名
      
      Range("C6").Cells(カウンタ + 1, 1).Value = Matchesコレクション.Item(カウンタ).SubMatches(2) & Space(1) & Matchesコレクション.Item(カウンタ).SubMatches(3)
      
      '指定日の日付部分を抽出
      文字列 = Range("C6").Cells(カウンタ + 1, 1).Value
      If InStr(文字列, ")") > 1 Then
         文字列 = Left(文字列, InStr(文字列, ")") - 1)
      ElseIf InStr(文字列, "）") > 1 Then
         文字列 = Left(文字列, InStr(文字列, "）") - 1)
      End If
      
      '最近の指定分を色分け
      日付 = 正規表現で置換("[^/0-9]", 文字列, "")

      If DateDiff("d", 日付, Date) < 7 Then
         Range("A6").Cells(カウンタ + 1, 1).Interior.ColorIndex = 7
         Range("B6").Cells(カウンタ + 1, 1).Interior.ColorIndex = 7
         Range("C6").Cells(カウンタ + 1, 1).Interior.ColorIndex = 7
      ElseIf DateDiff("d", 日付, Date) < 14 Then
         Range("A6").Cells(カウンタ + 1, 1).Interior.ColorIndex = 6
         Range("B6").Cells(カウンタ + 1, 1).Interior.ColorIndex = 6
         Range("C6").Cells(カウンタ + 1, 1).Interior.ColorIndex = 6
      End If
      
   Next カウンタ

End Sub


Function HTML取得ShiftJIS2UNICODE(url)

   'URLからHTML(ShiftJIS)を取得してUNICODEに変換して出力する関数
   Set XMLHTTPオブジェクト = CreateObject("MSXML2.XMLHTTP")

   Call XMLHTTPオブジェクト.Open("GET", url, False)
   'https://infith.com/system/access/vba_xmlhttp/

   Call XMLHTTPオブジェクト.send

   HTML取得ShiftJIS2UNICODE = StrConv(XMLHTTPオブジェクト.responseBody, vbUnicode)
   
End Function

For Each h in Worksheets(1).Hyperlinks
    If Instr(h.Name, "Microsoft") <> 0 Then h.Follow
Next

With Worksheets(1)
    .Hyperlinks.Add .Range("E5"), "http://www.gohere.com"
End With

With Worksheets(1)
    .Hyperlinks.Add Anchor:=.Range("a5"), _
        Address:="http://example.microsoft.com", _
        ScreenTip:="Microsoft Web Site", _
        TextToDisplay:="Microsoft"
End With

With Worksheets(1)
    .Hyperlinks.Add Anchor:=.Range("a5"), _
        Address:="mailto:someone@example.com?subject=hello", _
        ScreenTip:="Write us today", _
        TextToDisplay:="Support"
End With

Option Explicit
Option Base 1

'参考にさせていただいたサイト

'システムトレーダーの冒険の書
'http://yutarosnotebook.blog.fc2.com/
'時系列株価を取得できるVBScriptプログラム(ソース公開)
'http://yutarosnotebook.blog.fc2.com/blog-entry-104.html

'01：2016/12/13：作成

   Dim XMLHTTPオブジェクト As Object
   
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
'これで Sleepを使ってミリ秒単位で処理にウェイトを入れることができます。
   
   
Sub 理論株価を取得()

   Dim URL理論株価Web  As String
   Dim 文字列 As String
   Dim 銘柄コード As String
   Dim HTMLソース As String
   Dim 開始日時 As Variant
   Dim 終了日時 As Variant
   Dim 最終行 As Integer
   Dim 銘柄数 As Integer
   Dim 銘柄カウンタ As Integer
   Dim 番台 As String
   Dim 指定URL As String
   Dim 銘柄名 As String
   Dim 株価 As Single
   Dim 日付 As String
   Dim 理論株価 As Single
   Dim 文字配列
   Dim ページ行数 As Integer
   Dim 行数 As Integer
   Dim 行文字列 As String
   Dim 株価取得済 As String
   
   
   '理論株価Ｗｅｂから指定銘柄の理論株価を取得し、Excelシートに書き出すツールです。
   
   開始日時 = Now                ' 開始時刻を変数に格納します。
   
   ' 処理を高速化するため、自動計算停止
   Application.Calculation = xlCalculationManual

   'シートから基本情報を取得
   ThisWorkbook.Worksheets("指定登録").Activate
   URL理論株価Web = Range("B1").Value
   最終行 = Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row
   銘柄数 = 最終行 - 5
   
   '前回取得データを消去
   If 最終行 > 5 Then
      Range("B6:G" & 最終行).ClearContents
   End If
   
   Columns("B:F").Interior.Pattern = xlNone
'   Range("F6").Cells(銘柄カウンタ, 1).Interior.ColorIndex = xlColorIndexNone

   '銘柄を昇順に並び替え
   Range("A5").CurrentRegion.Sort _
      Key1:=Range("A5"), Order1:=xlAscending, _
      Header:=xlYes
   
   '以上が設定です。ここより下の行はメインプログラムとなります。
   
   For 銘柄カウンタ = 1 To 銘柄数
      株価取得済 = ""
      株価 = 0
      理論株価 = 0
      日付 = ""
      
      '株価コードを設定します
      銘柄コード = Range("A6").Cells(銘柄カウンタ, 1).Value
      番台 = Left(銘柄コード, 1) & String(3, "0")
      
      指定URL = URL理論株価Web & 番台 & "/" & 銘柄コード & ".htm"
      
      'WEB ページが Shift_JIS のためUNICODEに変換して取得
      HTMLソース = HTML取得ShiftJIS2UNICODE(指定URL)
      
      '1行ずつに分割
      文字配列 = Split(HTMLソース, vbNewLine)
      '全体行数を取得
      ページ行数 = UBound(文字配列)

      If ページ行数 = 0 Then
         Erase 文字配列
         '1行ずつに分割
         文字配列 = Split(HTMLソース, vbLf) '★★★ HTML の改行が Lf (UNIX系OS)の場合にも対応 ★★★
         '全体行数を取得
         ページ行数 = UBound(文字配列)
      End If

'      If 銘柄コード = "1357" Then Stop

      For 行数 = 1 To ページ行数
         行文字列 = 文字配列(行数)
         
         Debug.Print 行数
         Debug.Print 行文字列
           
         If InStr(行文字列, "<title>404") > 0 Then
            Range("B6").Cells(銘柄カウンタ, 1).Value = "ページが見つかりません"
            Exit For
         End If
         
         If InStr(行文字列, "<title>理論株価Ｗｅｂ") > 0 Then
            銘柄名 = Trim(正規表現で置換("<(.*?)>", 行文字列, ""))
            銘柄名 = Right(銘柄名, Len(銘柄名) - InStr(銘柄名, "＞"))
         End If
         
         If InStr(行文字列, "上場廃止") > 0 Then
            Range("B6").Cells(銘柄カウンタ, 1).Value = 銘柄名
            Range("D6").Cells(銘柄カウンタ, 1).Value = "上場廃止"
            Exit For
         End If
  
         If 株価取得済 = "" Then
            If InStr(行文字列, "<th class=""right_35"">株価</th>") > 0 Then
               行文字列 = 文字配列(行数 + 1)
               株価 = Trim(正規表現で置換("<(.*?)>", 行文字列, ""))
               行文字列 = 文字配列(行数 + 2)
               日付 = Trim(正規表現で置換("<(.*?)>", 行文字列, ""))

               行数 = 行数 + 2
               株価取得済 = "株価取得済"
            End If
         End If
         
         If InStr(行文字列, "<th class=""right_35"">理論株価</th>") > 0 Then
            行文字列 = 文字配列(行数 + 1)
            文字列 = Trim(正規表現で置換("<(.*?)>", 行文字列, ""))
            文字列 = Trim(Replace(文字列, "予", ""))
            文字列 = Trim(Replace(文字列, ",", ""))
            理論株価 = Val(文字列)

            Range("B6").Cells(銘柄カウンタ, 1).Value = 銘柄名
            Range("C6").Cells(銘柄カウンタ, 1).Value = 株価
            Range("D6").Cells(銘柄カウンタ, 1).Value = 日付
            Range("E6").Cells(銘柄カウンタ, 1).Value = 理論株価
'            Stop
            If Range("E6").Cells(銘柄カウンタ, 1).Value <> 0 Then
            
               Range("F6").Cells(銘柄カウンタ, 1).Value _
               = Range("C6").Cells(銘柄カウンタ, 1).Value / Range("E6").Cells(銘柄カウンタ, 1).Value
               
               If Range("E6").Cells(銘柄カウンタ, 1).Value < 100 Then
                  Range("E6").Cells(銘柄カウンタ, 1).Interior.ColorIndex = 3
               End If
               
               If Range("F6").Cells(銘柄カウンタ, 1).Value > 10 Then
                  Range("B6").Cells(銘柄カウンタ, 1).Interior.ColorIndex = 3
                  Range("F6").Cells(銘柄カウンタ, 1).Interior.ColorIndex = 3
               ElseIf Range("F6").Cells(銘柄カウンタ, 1).Value > 1.1 Then
                  Range("B6").Cells(銘柄カウンタ, 1).Interior.ColorIndex = 22
                  Range("F6").Cells(銘柄カウンタ, 1).Interior.ColorIndex = 22
               ElseIf Range("F6").Cells(銘柄カウンタ, 1).Value < 0.9 Then
                  Range("B6").Cells(銘柄カウンタ, 1).Interior.ColorIndex = 4
                  Range("F6").Cells(銘柄カウンタ, 1).Interior.ColorIndex = 4
               End If
            End If
            
            Exit For
         End If
      Next 行数 'html の Body データを一行ごとに読む

'Stop
   Next 銘柄カウンタ
   
   ' 自動計算停止解除
   Application.Calculation = xlCalculationAutomatic
    
   終了日時 = Now
   MsgBox "処理時間は、" _
   & Format(終了日時 - 開始日時, "hh時間nn分ss秒") & " でした。"

End Sub

Option Explicit
Option Base 1


'00：2015/09/18：作成
'01：2015/09/19：指定登録シートにYahooの株価と上昇下落率を追加

   Dim XMLHTTPオブジェクト As Object
   Dim URL株式株価Yahooファイナンス As String
   Dim 文字列 As String
   
   Dim 銘柄コード As String
   Dim ソース保存フォルダ As String
   
   Dim 計算日付 As Date
   Dim 前計算日付 As Date

Sub 信用ランキング20位の時系列株価を取得()

   Dim 開始日時 As Variant
   Dim 終了日時 As Variant
   
   開始日時 = Now                ' 開始時刻を変数に格納します。
   
   ' 処理を高速化するため、自動計算停止
   Application.Calculation = xlCalculationManual
   
   Call トレーダーズウェブから信用取引情報を取得
   Call 時系列株価を取得_コード重複対策付き
   
   ThisWorkbook.Worksheets("指定登録").Activate
   
   ' 自動計算停止解除
   Application.Calculation = xlCalculationAutomatic
    
   終了日時 = Now
   MsgBox "処理時間は、" _
   & Format(終了日時 - 開始日時, "hh時間nn分ss秒") & " でした。"
   
End Sub



Private Sub トレーダーズウェブから信用取引情報を取得()

   Dim URL信用ランキング As String
   Dim Matchesコレクション As Object
   Dim ファイルシステムオブジェクト As Object
   Dim 出力ファイルパス As String
   Dim キストストリームオブジェクト As Object
   Dim ソース保存フォルダ As String
   Dim 正規表現 As RegExp
   Dim HTMLソース As String
   Dim カウンタ As Integer
   Dim 最終行 As Integer
   Dim 日付 As Date
   Dim 銘柄コード As String
   Dim 銘柄名 As String
   Dim 列数 As Integer

   ThisWorkbook.Worksheets("指定登録").Activate
   URL信用ランキング = Range("B4").Value
   ソース保存フォルダ = Range("B3").Value

   '前回の取得銘柄のデータを削除
   最終行 = Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row
   Range("A6:J" & CStr(最終行)).Delete Shift:=xlUp

   Set ファイルシステムオブジェクト = CreateObject("Scripting.FileSystemObject")

   If Dir(ソース保存フォルダ, vbDirectory) = "" Then 'この名前のフォルダが存在しなければ
      MkDir ソース保存フォルダ
   End If
   
   Set 正規表現 = New RegExp

   '<tr><td class="td_con_ranking_5" align="right">4</td><td class="td_con_ranking_7" align="center">6888</td><td class="td_con_ranking_28" align="left">アクモス</td><td class="td_con_ranking_8" align="right">205.0</td><td class="td_con_ranking_13" align="right">624,100</td><td class="td_con_ranking_13y" align="right">442,400</td><td class="td_con_ranking_13" align="right">574,200</td><td class="td_con_ranking_13" align="right">165,300</td></tr>
   '<tr><td class="td_con_ranking_5" align="right">5</td><td class="td_con_ranking_7" align="center">7707</td><td class="td_con_ranking_28" align="left"> </td><td class="td_con_ranking_8" align="right"> </td><td class="td_con_ranking_13" align="right">413,000</td><td class="td_con_ranking_13y" align="right">413,000</td><td class="td_con_ranking_13" align="right">209,300</td><td class="td_con_ranking_13" align="right">209,300</td></tr>
   '                                                                       コード                                                      銘柄名                                                     現在値                                                            売残                                                            売残前週比                                                        買残                                                            買残前週比
   '<tr>.+?class="td_con_ranking_7" align="center">([0-9]{4})</td><td class="td_con_ranking_28" align="left">(.+?)</td><td class="td_con_ranking_8" align="right">([\.0-9|,]+)</td><td class="td_con_ranking_13" align="right">([\.0-9|,]+)</td><td class="td_con_ranking_13y" align="right">([\.0-9|,]+)</td><td class="td_con_ranking_13" align="right">([\.0-9|,]+)</td><td class="td_con_ranking_13" align="right">([\.0-9|,|-]+)</td>
   正規表現.Pattern = "<tr>.+?class=""td_con_ranking_7"" align=""center"">([0-9]{4})</td><td class=""td_con_ranking_28"" align=""left"">(.*?)</td><td class=""td_con_ranking_8"" align=""right"">([\.0-9|,| ]*)</td><td class=""td_con_ranking_13"" align=""right"">([\.0-9|,]+)</td><td class=""td_con_ranking_13y"" align=""right"">([\.0-9|,|-]+)</td><td class=""td_con_ranking_13"" align=""right"">([\.0-9|,]+)</td><td class=""td_con_ranking_13"" align=""right"">([\.0-9|,|-]+)</td>"
   
   正規表現.Global = True
   
   出力ファイルパス = ファイルシステムオブジェクト.buildPath(ソース保存フォルダ, "信用売残増加銘柄.txt")
   '構文：object.CreateTextFile(filename[, overwrite[, unicode]]) → ShiftJIS だとエラーになる文字があるため↓
   'http://blog.systemjp.net/entry/2013/04/10/191821 ←教えていただいたサイト
   'http://ameblo.jp/cashtray/entry-11066671774.html ←教えていただいたサイト
   Set キストストリームオブジェクト = ファイルシステムオブジェクト.CreateTextFile(出力ファイルパス, True, True)
   
   'WEB ページが Shift_JIS のためUNICODEに変換して取得
   HTMLソース = HTML取得ShiftJIS2UNICODE(URL信用ランキング)
   
   
   '検証用にHTMLソースを出力
   キストストリームオブジェクト.writeLine HTMLソース
   
   Set Matchesコレクション = 正規表現.Execute(HTMLソース)
   
   '1つめのマッチから順に、最後のマッチまで
   For カウンタ = 0 To Matchesコレクション.Count - 1
   
      銘柄コード = Matchesコレクション(カウンタ).SubMatches(0)
      ActiveSheet.Hyperlinks.Add Anchor:=Range("A6").Cells(カウンタ + 1, 1), Address:="", _
      SubAddress:="'" & 銘柄コード & "'!A1", TextToDisplay:=銘柄コード
      
      銘柄名 = Matchesコレクション(カウンタ).SubMatches(1)
      If 銘柄名 = "&nbsp;" Then
         銘柄名 = "空白"
      End If
      ActiveSheet.Hyperlinks.Add Anchor:=Range("B6").Cells(カウンタ + 1, 1), Address:="", _
      SubAddress:="'" & 銘柄コード & "'!A1", TextToDisplay:=銘柄名
      
      For 列数 = 1 To 5
         Range("F6").Cells(カウンタ + 1, 列数).Value = Matchesコレクション.Item(カウンタ).SubMatches(列数 + 1)
      Next 列数
      
      '信用売残増加ランキングと信用買残増加ランキングを色区分する
      If カウンタ < 20 Then
         Range("H6").Cells(カウンタ + 1, 1).Interior.ColorIndex = 4
      ElseIf カウンタ < 40 Then
         Range("J6").Cells(カウンタ + 1, 1).Interior.ColorIndex = 4
      End If
      
   Next カウンタ

End Sub



Private Sub 時系列株価を取得_コード重複対策付き()

   Dim HTMLタイトル As String
   Dim 正規表現タイトル As RegExp
   Dim Matchesコレクション As Object
   
'   Dim 銘柄コード As String
'   Dim ソース保存フォルダ As String
   Dim 取得ページ数 As Integer
   Dim ファイルシステムオブジェクト As Object
   Dim 出力ファイルパス As String
   Dim キストストリームオブジェクト As Object
   Dim 正規表現 As RegExp
   Dim 取得ページカウンタ As Integer
   Dim HTMLソース As String
   Dim Matchesコレクション As Object
   Dim カウンタ As Integer

   Dim 追加シート名初期 As String
   Dim 追加シート名 As String
   Dim 重複 As Integer
   Dim シート As Worksheet
   Dim シート数 As Integer

   Dim 列数 As Integer
   Dim 行数 As Integer
   Dim 文字列 As String
   Dim 銘柄配列() As Variant
   Dim 最終行 As Integer
   Dim 銘柄数 As Integer
   Dim 銘柄カウンタ As Integer
   Dim 処理行 As Integer
   Dim 銘柄コード索引 As Object        'Scripting.Dictionary オブジェクト
   Dim 指定登録シート As Worksheet
   Dim 標準偏差 As Single
   

   '★銘柄コード索引を作成★
   Set 銘柄コード索引 = CreateObject("Scripting.Dictionary")  '★連想配列の定義
   
   '時系列株価を取得し、Excelシートに書き出すツールです。
   
   '前回作成したシートがあれば削除
   For Each シート In ThisWorkbook.Worksheets
      If シート.Name <> "テンプレート" And シート.Name <> "指定登録" Then
         'シート名 テンプレート と 指定登録 以外のシートを削除
         Application.DisplayAlerts = False
         シート.Delete
         Application.DisplayAlerts = True
      End If
   Next シート
   
   ThisWorkbook.Worksheets("指定登録").Activate
   URL株式株価Yahooファイナンス = Range("B1").Value
   取得ページ数 = Int(Range("B2").Value / 20 + 0.99)
   最終行 = Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row
   銘柄数 = 最終行 - 5
   銘柄配列 = Range("A6").Resize(銘柄数, 1)
   ソース保存フォルダ = Range("B3").Value
   Set 指定登録シート = ActiveSheet
   
   
   '以上が設定です。ここより下の行はメインプログラムとなります。
   
   Set ファイルシステムオブジェクト = CreateObject("Scripting.FileSystemObject")
   
   If Dir(ソース保存フォルダ, vbDirectory) = "" Then 'この名前のフォルダが存在しなければ
      MkDir ソース保存フォルダ
   End If

   Set 正規表現 = New RegExp
   正規表現.Pattern = "(\d{4}年\d{1,2}月\d{1,2}日)</td><td>([\.0-9|,]+)</td><td>([\.0-9|,]+)</td><td>([\.0-9|,]+)</td><td>([\.0-9|,]+)</td><td>([\.0-9|,]+)</td><td>([\.0-9|,]+)"
   正規表現.Global = True
   
   'HTML のタイトル抽出用
   Set 正規表現タイトル = New RegExp
   With 正規表現タイトル
      .Pattern = "<title>.*</title>"
      .IgnoreCase = True '大文字小文字を区分しない
      .Global = False
   End With
   
   For 銘柄カウンタ = 1 To 銘柄数
   
      '株価コードを設定します
      銘柄コード = 銘柄配列(銘柄カウンタ, 1)
      
      '株価コードの既存チェック
      If 銘柄コード索引.Exists(銘柄コード) = False Then
         '新規銘柄コードの場合のみ、時系列データを取得する
         銘柄コード索引(銘柄コード) = 銘柄カウンタ
      
         出力ファイルパス = ファイルシステムオブジェクト.buildPath(ソース保存フォルダ, 銘柄コード & ".txt")
         '構文：object.CreateTextFile(filename[, overwrite[, unicode]]) → ShiftJIS だとエラーになる文字があるため↓
         'http://blog.systemjp.net/entry/2013/04/10/191821 ←教えていただいたサイト
         'http://ameblo.jp/cashtray/entry-11066671774.html ←教えていただいたサイト
         Set キストストリームオブジェクト = ファイルシステムオブジェクト.CreateTextFile(出力ファイルパス, True, True)
   
         追加シート名初期 = 銘柄コード
         追加シート名 = 追加シート名初期
      
         For 重複 = 1 To 100
         ' 100枚まで追加しても重複しないように追番を設定します。
             For Each シート In Worksheets
                 If シート.Name = 追加シート名 Then
                     追加シート名 = 追加シート名初期 & "(" & 重複 & ")"
                 End If
             Next シート
         Next 重複
         シート数 = Worksheets.Count
         Worksheets("テンプレート").Copy After:=Worksheets(シート数)
         ActiveSheet.Name = 追加シート名
         
         行数 = 0
         For 取得ページカウンタ = 1 To 取得ページ数
            HTMLソース = HTML取得(URL結合(銘柄コード, Date - 80 * 取得ページカウンタ, Date, 取得ページカウンタ))
             
            Range("A2").Value = URL結合(銘柄コード, Date - 80 * 取得ページカウンタ, Date, 取得ページカウンタ)
      
            '検証用にHTMLソースを出力
            キストストリームオブジェクト.writeLine HTMLソース
               
            'HTML のタイトル抽出
            Set Matchesコレクション = 正規表現タイトル.Execute(HTMLソース)
            文字列 = Matchesコレクション(0).Value
            HTMLタイトル = Trim(正規表現で置換("<(.*?)>", 文字列, ""))
               
            If InStr(HTMLタイトル, "：") > 0 Then
               Range("A1").Value = Trim(Left(HTMLタイトル, InStr(HTMLタイトル, "：") - 1))
            Else
               Range("A1").Value = HTMLタイトル
            End If
   
            '1行目から順に、最後の行まで
         
            Set Matchesコレクション = 正規表現.Execute(HTMLソース)
            For カウンタ = 0 To Matchesコレクション.Count - 1
               行数 = 行数 + 1
               For 列数 = 1 To 7
                  Range("A4").Cells(行数, 列数).Value = Matchesコレクション(カウンタ).SubMatches(列数 - 1)
               Next 列数
            Next カウンタ

         Next 取得ページカウンタ
         
         キストストリームオブジェクト.Close
         
         最終行 = Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row
         For 処理行 = 4 To 最終行 - 1
            '上昇下落率を計算してセルに書き出し
            Range("H1").Cells(処理行, 1).Value _
            = (Range("G1").Cells(処理行, 1).Value - Range("G1").Cells(処理行 + 1, 1).Value) / Range("G1").Cells(処理行 + 1, 1).Value
            
            If Range("H1").Cells(処理行, 1).Value >= 0.1 Then
               Range("H1").Cells(処理行, 1).Interior.ColorIndex = 7
            ElseIf Range("H1").Cells(処理行, 1).Value >= 0 Then
               Range("H1").Cells(処理行, 1).Interior.ColorIndex = 38
            ElseIf Range("H1").Cells(処理行, 1).Value <= -0.1 Then
               Range("H1").Cells(処理行, 1).Interior.ColorIndex = 8
            ElseIf Range("H1").Cells(処理行, 1).Value < 0 Then
               Range("H1").Cells(処理行, 1).Interior.ColorIndex = 20
            End If
         Next 処理行
         
         '標準偏差σを計算して、セルG1に登録
            '自動計算停止解除
         Application.Calculation = xlCalculationAutomatic
         Range("G1").Formula = "=STDEV(G4:G" & 最終行 & ")"
         標準偏差 = Range("G1").Value
            '処理を高速化するため、自動計算を再停止
         Application.Calculation = xlCalculationManual
         Range("G1").Value = 標準偏差
         
         '上昇下落率を指定登録シートに転記
         指定登録シート.Range("D6").Cells(銘柄カウンタ, 1).Value = Range("H4").Value
         '直近株価を指定登録シートに転記
         指定登録シート.Range("E6").Cells(銘柄カウンタ, 1).Value = Range("G4").Value
         '直近株価に対する標準偏差の率を指定登録シートに転記
         指定登録シート.Range("C6").Cells(銘柄カウンタ, 1).Value = Range("G1").Value / Range("G4").Value
         '標準偏差率が10%以上に水色を付ける
         If 指定登録シート.Range("C6").Cells(銘柄カウンタ, 1).Value >= 0.1 Then
            指定登録シート.Range("C6").Cells(銘柄カウンタ, 1).Interior.ColorIndex = 8
         End If
         
         Call 信用残時系列を追記
         Call 機関の空売り残高情報を追記
         
      Else
         '銘柄が既存の場合は、既に取得済の標準偏差率、上昇下落率、直近株価を転記
         For 列数 = 1 To 3
         指定登録シート.Range("C6").Cells(銘柄カウンタ, 列数).Value _
         = 指定登録シート.Range("C6").Cells(銘柄コード索引(銘柄コード), 列数).Value
         Next 列数
         '重複出現がわかるようにセル背景を黄色に
         指定登録シート.Range("A6").Cells(銘柄カウンタ, 1).Resize(1, 2).Interior.ColorIndex = 6
         指定登録シート.Range("A6").Cells(銘柄コード索引(銘柄コード), 1).Resize(1, 2).Interior.ColorIndex = 6

      End If
      
   Next 銘柄カウンタ

End Sub



Private Sub 機関の空売り残高情報を追記()
   Dim ファイルシステムオブジェクト As Object
   Dim 出力ファイルパス As String
   Dim キストストリームオブジェクト As Object
   Dim 正規表現 As RegExp
   Dim HTMLソース As String
   Dim Matchesコレクション As Object
   Dim カウンタ As Integer
   Dim 行数 As Integer
   Dim 最終行 As Integer
   
   Dim URL_karauri_net As String
   Dim 株価日付 As Date

   
   '機関の空売り残高情報を取得して、時系列株価情報のExcelシートに追記します。
   
   URL_karauri_net = "https://karauri.net/"

   Set 正規表現 = New RegExp
   '　　　　　　　　　　　　　　　　計算日　　　　　　　　　　　　　　　　空売り者 　　　　　　　　　　　　残高割合　　　　　　　　　　　　　　　　増減率　　　　　　　　　　　　　　　 残高数量　　　　　　　　　　　　　　　増減量  　　　　　　　　　　　　　　備考
   正規表現.Pattern = ">([0-9]{4}/[0-9]{2}/[0-9]{2})<.*/td><td class=""lf""><a .+?>(.*?)</a></td><td class=""ct"">([\.0-9|,]+%)</td><td class=""ct.*?"">([\.0-9|+,-]+%)</td><td class=""ct"">([\.0-9|,]+株)</td><td.*?>([\.0-9|+,-]*)</td><td class=""lf"".*?>(.*)<.*?/td></tr>"
   正規表現.Global = True
   

   HTMLソース = HTML取得(URL_karauri_net & 銘柄コード & "/")
   
   '</tr>の後に改行を追加してソースを見やすくする
   HTMLソース = 正規表現で置換("</tr>", HTMLソース, "</tr>★改行★")
   HTMLソース = Replace(HTMLソース, "★改行★", vbNewLine)
   
   '検証用にHTMLソースを出力
   Set ファイルシステムオブジェクト = CreateObject("Scripting.FileSystemObject")
   出力ファイルパス = ファイルシステムオブジェクト.buildPath(ソース保存フォルダ, 銘柄コード & "空売り残高情報.txt")
   '構文：object.CreateTextFile(filename[, overwrite[, unicode]]) → ShiftJIS だとエラーになる文字があるため↓
   'http://blog.systemjp.net/entry/2013/04/10/191821 ←教えていただいたサイト
   'http://ameblo.jp/cashtray/entry-11066671774.html ←教えていただいたサイト
   Set キストストリームオブジェクト = ファイルシステムオブジェクト.CreateTextFile(出力ファイルパス, True, True)
   キストストリームオブジェクト.writeLine HTMLソース
   
'   Stop
   
   '1行目から順に、最後の行まで

   Set Matchesコレクション = 正規表現.Execute(HTMLソース)
   
   最終行 = Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row
   行数 = 0
   
   For カウンタ = 0 To Matchesコレクション.Count - 1
   
      計算日付 = Matchesコレクション(カウンタ).SubMatches(0)

      If 計算日付 = 前計算日付 Then
         行数 = 行数 + 1
         'コピーや切取りの操作を取り消します
         Application.CutCopyMode = False
         '行を追加します
         Range("A4").Cells(行数, 1).EntireRow.Insert
         Range("A4").Cells(行数, 1).Value = Range("A4").Cells(行数 - 1, 1).Value
         最終行 = 最終行 + 1
         
         If 計算日付 = 株価日付 Then
            Call 機関の日付列データ登録(Matchesコレクション, カウンタ, 行数)
         End If
         
      Else
         Do While 計算日付 <> 株価日付
            行数 = 行数 + 1
            If 行数 > 最終行 Then Exit Do '信用残日付データの方が株価日付のデータより多い場合は、抜ける
            
            株価日付 = Range("A4").Cells(行数, 1).Value
            
            If 計算日付 = 株価日付 Then
               Call 機関の日付列データ登録(Matchesコレクション, カウンタ, 行数)
               Exit Do
            ElseIf 株価日付 <> "0:00:00" And 計算日付 > 株価日付 Then
            
               '行を追加します
               Range("A4").Cells(行数, 1).EntireRow.Insert
               Range("A4").Cells(行数, 1).Value = 計算日付
               
               Call 機関の日付列データ登録(Matchesコレクション, カウンタ, 行数)
   
               最終行 = 最終行 + 1
               Exit Do
            End If
         Loop

      End If
   Next カウンタ

End Sub



Private Sub 機関の日付列データ登録(Matchesコレクション, カウンタ, 行数)
   Dim 列数 As Integer
   For 列数 = 1 To 6
         文字列 = Matchesコレクション.Item(カウンタ).SubMatches(列数)
         Range("L4").Cells(行数, 列数).Value = 正規表現で置換("<(.*?)>", 文字列, "")
   Next 列数
   前計算日付 = 計算日付
End Sub



Private Sub 信用残時系列を追記()

   Dim ファイルシステムオブジェクト As Object
   Dim 出力ファイルパス As String
   Dim キストストリームオブジェクト As Object
   Dim 正規表現 As RegExp
   Dim HTMLソース As String
   Dim Matchesコレクション As Object
   Dim カウンタ As Integer

   Dim 列数 As Integer
   Dim 行数 As Integer
   Dim 最終行 As Integer
   
   Dim URL株探Kabutan信用残 As String
   Dim 株価日付 As Date
   Dim 信用残日付 As Date

   
   '信用残時系列データを取得して、時系列株価情報のExcelシートに追記します。
   
   URL株探Kabutan信用残 = "https://kabutan.jp/stock/kabuka?code="

   Set 正規表現 = New RegExp
   '                                                          日付                                売残                 買残                信用倍率
   正規表現.Pattern = "<td style=""text-align:center;"">([0-9]{2}/[0-9]{2}/[0-9]{2})</td>.*<td>([,0-9|−]+)</td><td>([,0-9|−]+)</td><td>([\.0-9|,|−]+)</td></tr>"
   正規表現.Global = True
   

   HTMLソース = HTML取得(URL株探Kabutan信用残 & 銘柄コード & "&ashi=shin")
   
   '</td>の後の改行を外す
   HTMLソース = 正規表現で置換("</td>\r\n", HTMLソース, "</td>")
   
   '検証用にHTMLソースを出力
   Set ファイルシステムオブジェクト = CreateObject("Scripting.FileSystemObject")
   出力ファイルパス = ファイルシステムオブジェクト.buildPath(ソース保存フォルダ, 銘柄コード & "信用残時系列.txt")
   '構文：object.CreateTextFile(filename[, overwrite[, unicode]]) → ShiftJIS だとエラーになる文字があるため↓
   'http://blog.systemjp.net/entry/2013/04/10/191821 ←教えていただいたサイト
   'http://ameblo.jp/cashtray/entry-11066671774.html ←教えていただいたサイト
   Set キストストリームオブジェクト = ファイルシステムオブジェクト.CreateTextFile(出力ファイルパス, True, True)
   キストストリームオブジェクト.writeLine HTMLソース

   '1行目から順に、最後の行まで

   Set Matchesコレクション = 正規表現.Execute(HTMLソース)
   
   最終行 = Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row
   行数 = 0
   
   For カウンタ = 0 To Matchesコレクション.Count - 1
   
      信用残日付 = Matchesコレクション(カウンタ).SubMatches(0)
      
      Do While 信用残日付 <> 株価日付
         行数 = 行数 + 1
         If 行数 > 最終行 Then Exit Do '信用残日付データの方が株価日付のデータより多い場合は、抜ける
         
         株価日付 = Range("A4").Cells(行数, 1).Value
         If 信用残日付 = 株価日付 Then
            For 列数 = 1 To 3
               Range("I4").Cells(行数, 列数).Value = Matchesコレクション.Item(カウンタ).SubMatches(列数)
            Next 列数
            
         End If
      Loop
      
   Next カウンタ
       
End Sub

Option Explicit
Option Base 1


'00：2015/07/20：「GetTimeSeriesStockPricesVBA03.xls」をベースに、対象HTMLDocument.createDocumentFromUrl()を使うように移植


   Dim URL株式株価Yahooファイナンス As String

   Dim HTMLソース As String
   Dim HTMLタイトル As String
   
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
'これで Sleepを使ってミリ秒単位で処理にウェイトを入れることができます。

Sub 時系列株価を取得()
   
   Dim 銘柄コード As String
   Dim SaveFolder As String
   Dim 取得ページ数 As Integer
   Dim ファイルシステムオブジェクト As Object
   Dim 出力ファイルパス As String
   Dim キストストリームオブジェクト As Object
   Dim 正規表現 As RegExp
   Dim 取得ページカウンタ As Integer

   Dim Matchesコレクション As Object
   Dim カウンタ As Integer
   Dim 開始日時 As Variant
   Dim 終了日時 As Variant
   Dim 追加シート名初期 As String
   Dim 追加シート名 As String
   Dim 重複 As Integer
   Dim シート As Worksheet
   Dim シート数 As Integer

   Dim 列数 As Integer
   Dim 行数 As Integer
   Dim 文字列 As String
   Dim 銘柄配列() As Variant
   Dim 最終行 As Integer
   Dim 銘柄数 As Integer
   Dim 銘柄カウンタ As Integer
   
   '時系列株価を取得し、Excelシートに書き出すツールです。
   
   開始日時 = Now                ' 開始時刻を変数に格納します。
   
   ' 処理を高速化するため、自動計算停止
   Application.Calculation = xlCalculationManual

   '前回作成したシートがあれば削除
   For Each シート In ThisWorkbook.Worksheets
      If シート.Name <> "テンプレート" And シート.Name <> "指定登録" Then
         'シート名 テンプレート と 指定登録 以外のシートを削除
         Application.DisplayAlerts = False
         シート.Delete
         Application.DisplayAlerts = True
      End If
   Next シート
   
   ThisWorkbook.Worksheets("指定登録").Activate
   URL株式株価Yahooファイナンス = Range("B1").Value
   取得ページ数 = Int(Range("B2").Value / 20 + 0.99)
   最終行 = Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row
   銘柄数 = 最終行 - 5
   銘柄配列 = Range("A6").Resize(銘柄数, 1)
   SaveFolder = Range("B3").Value
   
   '以上が設定です。ここより下の行はメインプログラムとなります。
   
   Set ファイルシステムオブジェクト = CreateObject("Scripting.FileSystemObject")
   
   If Not ファイルシステムオブジェクト.FolderExists(SaveFolder) Then
       MsgBox "保存先フォルダが存在しません"
       Exit Sub
   End If
   

   Set 正規表現 = New RegExp
   正規表現.Pattern = "(\d{4}年\d{1,2}月\d{1,2}日)</td><td>([\.0-9|,]+)</td><td>([\.0-9|,]+)</td><td>([\.0-9|,]+)</td><td>([\.0-9|,]+)</td><td>([\.0-9|,]+)</td><td>([\.0-9|,]+)"
   正規表現.IgnoreCase = True   '大文字小文字を区分しない
   正規表現.Global = True
   

   For 銘柄カウンタ = 1 To 銘柄数
   
      '株価コードを設定します
      銘柄コード = 銘柄配列(銘柄カウンタ, 1)
   
      出力ファイルパス = ファイルシステムオブジェクト.buildPath(SaveFolder, 銘柄コード & ".txt")
      '構文：object.CreateTextFile(filename[, overwrite[, unicode]]) → ShiftJIS だとエラーになる文字があるため↓
      'http://blog.systemjp.net/entry/2013/04/10/191821 ←教えていただいたサイト
      'http://ameblo.jp/cashtray/entry-11066671774.html ←教えていただいたサイト
      Set キストストリームオブジェクト = ファイルシステムオブジェクト.CreateTextFile(出力ファイルパス, True, True)

      追加シート名初期 = 銘柄コード
      追加シート名 = 追加シート名初期
   
      For 重複 = 1 To 100
      ' 100枚まで追加しても重複しないように追番を設定します。
          For Each シート In Worksheets
              If シート.Name = 追加シート名 Then
                  追加シート名 = 追加シート名初期 & "(" & 重複 & ")"
              End If
          Next シート
      Next 重複
      シート数 = Worksheets.Count
      Worksheets("テンプレート").Copy After:=Worksheets(シート数)
      ActiveSheet.Name = 追加シート名
      
      行数 = 0
      For 取得ページカウンタ = 1 To 取得ページ数
         Call HTML取得(URL結合(銘柄コード, Date - 80 * 取得ページカウンタ, Date, 取得ページカウンタ))
          
         Range("A2").Value = URL結合(銘柄コード, Date - 80 * 取得ページカウンタ, Date, 取得ページカウンタ)
   
         '検証用にHTMLソースを出力
         キストストリームオブジェクト.writeLine HTMLソース

         If InStr(HTMLタイトル, "：") > 0 Then
            Range("A1").Value = Trim(Left(HTMLタイトル, InStr(HTMLタイトル, "：") - 1))
         Else
            Range("A1").Value = HTMLタイトル
         End If

         '1行目から順に、最後の行まで
      
         Set Matchesコレクション = 正規表現.Execute(HTMLソース)
         For カウンタ = 0 To Matchesコレクション.Count - 1
            行数 = 行数 + 1
            For 列数 = 1 To 7
               Range("A4").Cells(行数, 列数).Value = Matchesコレクション(カウンタ).SubMatches(列数 - 1)
            Next 列数
         Next カウンタ
          
         'SubMatches コレクションとは、正規表現のサブマッチ文字列のコレクションです。
         'SubMatches コレクションには、個別のサブマッチ文字列が格納されます。
         'このコレクションは、RegExp オブジェクトの Execute メソッドによってのみ作成可能です。
         'SubMatches コレクションのプロパティは、すべて読み取り専用です。
         '正規表現で検索を実行すると、サブ条件が取得を示すかっこで囲まれている場合にサブマッチ文字列が 0 個以上作成されます。
         'SubMatches コレクションの各項目は、正規表現によって検索および取得される文字列です。
   
      Next 取得ページカウンタ
      
      キストストリームオブジェクト.Close
   
   Next 銘柄カウンタ
   
   ' 自動計算停止解除
   Application.Calculation = xlCalculationAutomatic
   
   終了日時 = Now
   MsgBox "処理時間は、" _
   & Format(終了日時 - 開始日時, "hh時間nn分ss秒") & " でした。"

End Sub



Private Sub HTML取得(url)
   Dim 対象HTMLDocument As HTMLDocument
   Dim HTML文書 As HTMLDocument
   Dim ループ回数 As Integer
   
   Set 対象HTMLDocument = New HTMLDocument

 'URLからHTMLDocumentを取得する
   Set HTML文書 = 対象HTMLDocument.createDocumentFromUrl(url, vbNullString) 'HTML文書をDOMとして取得

   ' ダウンロード待ち
   ループ回数 = 0
   Do While HTML文書.readyState <> "complete"
      DoEvents       ' Sleep しているときに、画面を書き換えできるように、OS に制御を渡す。
      Sleep (100)
      ループ回数 = ループ回数 + 1
      Range("H1").Value = ループ回数
      If ループ回数 > 1000 Then
         MsgBox "サイトのデータ取得に時間がかかっているので、一旦 中断します"
         Exit Sub
      End If
   Loop
   'HTML のタイトル抽出
   HTMLタイトル = HTML文書.Title
   
   'HTML の BODY 抽出
   HTMLソース = HTML文書.body.innerHTML
   HTMLソース = Replace(HTMLソース, vbNewLine, "") 'HTML の改行を削除
   
   Set HTML文書 = Nothing
   Set 対象HTMLDocument = Nothing
   
End Sub

Option Explicit
Option Base 1

   Dim データ配列() As Variant
   Dim 最終行数 As Integer
   Dim 処理行 As Integer
   Dim 対象URL As String
   Dim バージョン As Integer
   Dim IEオブジェクト As Object
   Dim inputタグオブジェクト As Object
   Dim タグオブジェクト As Object
   Dim 入力行 As Integer
   Dim 処理 As String
   Dim Shellオブジェクト As Object
   Dim 開いているIEオブジェクト As Object
   Dim HTMLソース As String
   Dim 開いているURL As String
   Dim 上限値 As Long
   Dim 下限値 As Long
   Dim 売却可能数量 As Long
   Dim 文字列 As String
   Dim 文字配列() As String
   Dim ページ行数 As Integer
   Dim 行文字列 As String
   Dim 行数 As Integer
   Dim 文字列temp As String
   Dim 注文単価 As Long
   Dim HTMLタイトル As String
   Dim 銘柄名 As String
   Dim フォーム数 As Integer
   Dim 開始日時 As Variant
   Dim 終了日時 As Variant

Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
'これで Sleepを使ってミリ秒単位で処理にウェイトを入れることができます。


Sub 日興證券国内株式注文約定登録()

   開始日時 = Now                ' 開始時刻を変数に格納します。

   ThisWorkbook.Worksheets("指定登録").Activate

   Call IEバージョンを知る(バージョン)

   データ配列 = Range("A1").CurrentRegion.Value

   最終行数 = UBound(データ配列)

   'Shell.Applicationオブジェクトの作成
   Set Shellオブジェクト = CreateObject("Shell.Application")

   For 処理行 = 2 To 最終行数 '1行目はヘッダー情報なので、読み飛ばして、2行目からを扱う

      If データ配列(処理行, 2) = "" Then   '銘柄コードが空白の行に到達したら、処理を終る
         Exit For
      End If

      If データ配列(処理行, 1) = True Then 'A列の対象でチェック(True)をした行のみを対象にする
         注文単価 = データ配列(処理行, 6)
         Select Case データ配列(処理行, 4) '売りと買いで、処理が違うので、場合分けする

         '★★★　"売"　★★★　"売　★★★　"売"　★★★"　"売"　★★★
            Case "売"

               対象URL = "https://trade.smbcnikko.co.jp/StockOrderConfirmation/B5C2O0066177/kbodr/uri_odr/hyji?specifyMeig=1&meigCd=00" _
               & データ配列(処理行, 2) & "0000&knrkokbn=0"

               If バージョン > "6" Then

                  'IEオブジェクトの作成(ダミー)
                  Set IEオブジェクト = CreateObject("InternetExplorer.Application")

                  IEオブジェクト.Navigate2 対象URL     '★IE7の場合、既存or新しいウィンドウで表示される
                  If 入力行 = 1 Then
                     IEオブジェクト.Quit               '★IE7の場合、ここで閉じるのはCreateObjectで作成したウィンドウ
                     Set IEオブジェクト = Nothing      '★IE7の場合、いったんオブジェクトをクリア
                     Application.Wait Now + TimeValue("00:00:01")
                  End If

                  処理 = "Shell.ApplicationオブジェクトのWindowオブジェクトからIEオブジェクトを取り出す"
                  '作成されているポイントは、Windowsコレクションの最後の要素

                  Set IEオブジェクト = Shellオブジェクト.Windows.Item(Shellオブジェクト.Windows.Count - 1)
                  'これ以降は、従来と同様の方法で操作が可能
                  With IEオブジェクト
                     .Navigate 対象URL
                     .Visible = True
                  End With

                  Call IE表示待ち
               Else
                  '★IE6以前の場合
                  Set IEオブジェクト = CreateObject("InternetExplorer.Application")

                  With IEオブジェクト
                     .Navigate 対象URL
                     .Visible = True
                  End With

                  Call IE表示待ち

               End If

               '前回のメッセージを削除
               Range("H1").Cells(処理行, 1).Value = ""

               'タイトルを取得
               HTMLタイトル = IEオブジェクト.Document.Title
               If InStr(HTMLタイトル, "売り注文 エラー") > 0 Then
                  Range("H1").Cells(処理行, 1).Value _
                  = "売り注文 エラー"
                  IEオブジェクト.Quit
                  GoTo 次の処理行へ
               End If

               '表示したページの<BODY>部のHTMLを取得し、イミディエイト・ウインドウに表示
               HTMLソース = IEオブジェクト.Document.body.innerHTML
               Debug.Print HTMLソース

               '1行ずつに分割
               Erase 文字配列
               文字配列 = Split(HTMLソース, vbNewLine)

               '全体行数を取得
               ページ行数 = UBound(文字配列)

               If ページ行数 = 0 Then 'vbNewLine で行分割できなかった場合
                  '1行ずつに分割
                  Erase 文字配列
                  文字配列 = Split(HTMLソース, vbLf)
                  '全体行数を取得
                  ページ行数 = UBound(文字配列)
               End If

               For 行数 = 1 To ページ行数
                  行文字列 = 文字配列(行数)

                  If InStr(行文字列, "ご指定の銘柄は存在しません") > 0 Then
                        Range("H1").Cells(処理行, 1).Value _
                        = "ご指定の銘柄は存在しません"
                        IEオブジェクト.Quit
                        GoTo 次の処理行へ

                  ElseIf InStr(行文字列, "sinkbShitei") > 0 Then
                     銘柄名 = Replace(正規表現で置換("<(.*?)>", 行文字列, ""), "　", "")
                     If データ配列(処理行, 3) = "" Then
                        Range("C1").Cells(処理行, 1).Value = 銘柄名 '銘柄の列が空白の場合、銘柄名を表示
                     End If
                  ElseIf InStr(行文字列, "以上") > 0 And InStr(行文字列, "以下") > 0 Then
                     'HTML のタグを削除。カンマ区切りの数値をValで数値変換すると、,より前しか取得しないので、,を外す。
                     文字列 = Replace(正規表現で置換("<(.*?)>", 行文字列, ""), ",", "")

                     文字列temp = Left(文字列, InStr(文字列, "/") - 1)
                     下限値 = Val(Right(文字列temp, Len(文字列temp) - InStrRev(文字列temp, "-")))
                     上限値 = Val(Right(文字列, Len(文字列) - InStr(文字列, "/")))

                     If 下限値 > データ配列(処理行, 6) Then ' 注文単価が、下限値以下
                        注文単価 = 下限値
                        Range("H1").Cells(処理行, 1).Value _
                        = "注文単価" & CStr(データ配列(処理行, 6)) & "が、下限値" & 下限値 & "未満なので、下限値を注文単価にしました。"
                     End If

                  ElseIf InStr(行文字列, "特定口座：") > 0 Then

                     文字列temp = 正規表現で置換("<(.*?)>", 行文字列, "")
                     文字列temp = Replace(文字列temp, "特定口座：", "")
                     文字列temp = Replace(文字列temp, ",", "")
                     売却可能数量 = Val(文字列temp) '特定口座の売却可能数量

                     If データ配列(処理行, 5) > 売却可能数量 Then
                        Range("H1").Cells(処理行, 1).Value _
                        = "注文数量" & CStr(データ配列(処理行, 5)) & "が、売却可能数量" & 売却可能数量 & "以上なので、スキップしました。"
                        IEオブジェクト.Quit
                        GoTo 次の処理行へ
                     End If
                     Exit For
                  End If

               Next 行数

               IEオブジェクト.Document.Forms("frm_chart")("suryo").Value = データ配列(処理行, 5)  '数量
               IEオブジェクト.Document.Forms("frm_chart")("nariSasiKbn").sasi.Click               '指値
               IEオブジェクト.Document.Forms("frm_chart")("kakaku").Value = 注文単価              '注文単価
               IEオブジェクト.Document.Forms("frm_chart")("yukokikan").konsy.Click                '期間指定

               IEオブジェクト.Document.Forms("frm_chart").Submit

               '★★売り注文確認画面★★

               '起動した IE が 必ず 絶対 一番後ろ と決め付けて(プログラマーに絶対は無いだろクソ三流)
               Set 開いているIEオブジェクト = Shellオブジェクト.Windows(Shellオブジェクト.Windows.Count - 1)
               '↑配列が０からなのでカウント-１ 一番後ろのWindowをobjIEに代入

               Call IE表示待ち

               開いているURL = 開いているIEオブジェクト.LocationURL

               '表示したページの<BODY>部のHTMLを取得し、イミディエイト・ウインドウに表示
               HTMLソース = 開いているIEオブジェクト.Document.body.innerHTML
               Debug.Print HTMLソース

               'JavaScriptのwindow.document.formsオブジェクト
               'http://freematerial.fc2web.com/ref_js/ref_js_w_d_f.html
               'JavaScript/DOM  ≫  ドキュメント内の要素数と、各要素の情報を取得
               'http://phpjavascriptroom.com/?t=js&p=document_elements
               フォーム数 = 開いているIEオブジェクト.Document.Forms.Length

               ' http://www.ken3.org/cgi-bin/group/vba_ie_form.asp
               For Each タグオブジェクト In 開いているIEオブジェクト.Document.Forms(2) '構成要素を１つ１つ取り出す

                   If タグオブジェクト.Name = "insider" Then 'インサイダーチェックが見つかったか？
                       タグオブジェクト.Checked = True       '.Checked = True で チェックを付ける
                       Exit For                              '探し終わったのでループを抜ける
                   End If
               Next

               'ひこなんのVBAサンプルコード
               ' IE操作_inputﾀｸﾞからalt属性で｢検索する｣を見つけてｸﾘｯｸする(MSHTML.HTMLImg.altﾌﾟﾛﾊﾟﾃｨ)
               'http://www.geocities.jp/samplecode_20130202/Sample/39845502762427578621927533367210465433073247662476393678643923581.html
               For Each inputタグオブジェクト In 開いているIEオブジェクト.Document.all.tags("input")
                  If inputタグオブジェクト.alt = "注文する" Then
                     inputタグオブジェクト.Click
                     Exit For
                  End If
               Next

               開いているIEオブジェクト.Quit

         '★★★　"買"　★★★　"買　★★★　"買"　★★★"　"買"　★★★
            Case "買"

               対象URL = "https://trade.smbcnikko.co.jp/StockOrderConfirmation/215932/kbodr/kai_odr/hyji?specifyMeig=1&meigCd=00" _
               & データ配列(処理行, 2) & "0000"

               Set IEオブジェクト = CreateObject("InternetExplorer.Application")

               If バージョン > "6" Then
                  IEオブジェクト.Navigate2 対象URL     '★IE7の場合、既存or新しいウィンドウで表示される
                  If 入力行 = 1 Then
                     IEオブジェクト.Quit               '★IE7の場合、ここで閉じるのはCreateObjectで作成したウィンドウ
                     Set IEオブジェクト = Nothing      '★IE7の場合、いったんオブジェクトをクリア
                     Application.Wait Now + TimeValue("00:00:01")
                  End If

                  処理 = "Shell.ApplicationオブジェクトのWindowオブジェクトからIEオブジェクトを取り出す"
                       '作成されているポイントは、Windowsコレクションの最後の要素

                  Set IEオブジェクト = Shellオブジェクト.Windows.Item(Shellオブジェクト.Windows.Count - 1)
                  'これ以降は、従来と同様の方法で操作が可能
                  With IEオブジェクト
                     .Navigate 対象URL
                     .Visible = True
                  End With

                  Call IE表示待ち

               Else
                  '★IE6以前の場合
                  Set IEオブジェクト = CreateObject("InternetExplorer.Application")

                  With IEオブジェクト
                     .Navigate 対象URL
                     .Visible = True
                  End With

                  Call IE表示待ち
               End If

               '前回のメッセージを削除
               Range("H1").Cells(処理行, 1).Value = ""

               'タイトルを取得
               HTMLタイトル = IEオブジェクト.Document.Title
               If InStr(HTMLタイトル, "買い注文 エラー") > 0 Then
                  Range("H1").Cells(処理行, 1).Value _
                  = "買い注文 エラー"
                  IEオブジェクト.Quit
                  GoTo 次の処理行へ
               End If

               '表示したページの<BODY>部のHTMLを取得し、イミディエイト・ウインドウに表示
               HTMLソース = IEオブジェクト.Document.body.innerHTML
               Debug.Print HTMLソース

               '1行ずつに分割
               Erase 文字配列
               文字配列 = Split(HTMLソース, vbNewLine)

               '全体行数を取得
               ページ行数 = UBound(文字配列)

               If ページ行数 = 0 Then 'vbNewLine で行分割できなかった場合
                  '1行ずつに分割
                  Erase 文字配列
                  文字配列 = Split(HTMLソース, vbLf)
                  '全体行数を取得
                  ページ行数 = UBound(文字配列)
               End If

               For 行数 = 1 To ページ行数
                  行文字列 = 文字配列(行数)

                  If InStr(行文字列, "sinkbShitei") > 0 Then
                     銘柄名 = Replace(正規表現で置換("<(.*?)>", 行文字列, ""), "　", "")
                     If データ配列(処理行, 3) = "" Then
                        Range("C1").Cells(処理行, 1).Value = 銘柄名 '銘柄の列が空白の場合、銘柄名を表示
                     End If

                  ElseIf InStr(行文字列, "以上") > 0 And InStr(行文字列, "以下") > 0 Then
                     'HTML のタグを削除。カンマ区切りの数値をValで数値変換すると、,より前しか取得しないので、,を外す。
                     文字列 = Replace(正規表現で置換("<(.*?)>", 行文字列, ""), ",", "")
                     文字列temp = Left(文字列, InStr(文字列, "/") - 1)
                     下限値 = Val(Right(文字列temp, Len(文字列temp) - InStrRev(文字列temp, "-")))
                     上限値 = Val(Right(文字列, Len(文字列) - InStr(文字列, "/")))

                     If 上限値 > 0 And 上限値 < データ配列(処理行, 6) Then ' 注文単価が、上限値以上
                        注文単価 = 上限値
                        Range("H1").Cells(処理行, 1).Value _
                        = "注文単価" & CStr(データ配列(処理行, 6)) & "が、上限値" & 上限値 & "以上なので、上限値を注文単価にしました。"
                     End If
                     Exit For
                  End If

               Next 行数

               IEオブジェクト.Document.Forms("frm_chart")("suryo").Value = データ配列(処理行, 5)  '数量
               IEオブジェクト.Document.Forms("frm_chart")("nariSasiKbn").sasi.Click               '指値
               IEオブジェクト.Document.Forms("frm_chart")("kakaku").Value = 注文単価              '注文単価
               IEオブジェクト.Document.Forms("frm_chart")("yukokikan").konsy.Click                '期間指定

               IEオブジェクト.Document.Forms("frm_chart").Submit

               '★★買い注文確認画面★★

               '起動した IE が 必ず 絶対 一番後ろ と決め付けて(プログラマーに絶対は無いだろクソ三流)
               Set 開いているIEオブジェクト = Shellオブジェクト.Windows(Shellオブジェクト.Windows.Count - 1)
               '↑配列が０からなのでカウント-１ 一番後ろのWindowをobjIEに代入

               Call IE表示待ち

               開いているURL = 開いているIEオブジェクト.LocationURL

               '表示したページの<BODY>部のHTMLを取得し、イミディエイト・ウインドウに表示
               HTMLソース = 開いているIEオブジェクト.Document.body.innerHTML
               Debug.Print HTMLソース

               'JavaScriptのwindow.document.formsオブジェクト
               'http://freematerial.fc2web.com/ref_js/ref_js_w_d_f.html
               'JavaScript/DOM  ≫  ドキュメント内の要素数と、各要素の情報を取得
               'http://phpjavascriptroom.com/?t=js&p=document_elements
               フォーム数 = 開いているIEオブジェクト.Document.Forms.Length

               ' http://www.ken3.org/cgi-bin/group/vba_ie_form.asp
               For Each タグオブジェクト In 開いているIEオブジェクト.Document.Forms(2) '構成要素を１つ１つ取り出す
                   '名前がinsiderのデータを探す
                   If タグオブジェクト.Name = "insider" Then 'インサイダーチェックが見つかったか？
                       タグオブジェクト.Checked = True       '.Checked = True で チェックを付ける
                       Exit For                              '探し終わったのでループを抜ける
                   End If
               Next

               For Each inputタグオブジェクト In 開いているIEオブジェクト.Document.all.tags("input")
                  If inputタグオブジェクト.alt = "注文する" Then
                     inputタグオブジェクト.Click
                     Exit For
                  End If
               Next

               開いているIEオブジェクト.Quit

            Case Else
               MsgBox "売買の指定を認識できません。この行をスキップします。" & vbNewLine _
               & 処理行 & データ配列(処理行, 2) & データ配列(処理行, 3)

         End Select

      End If
次の処理行へ:
   Next 処理行

   Set IEオブジェクト = Nothing
   Set Shellオブジェクト = Nothing   'この変数は 用済みなので、バイバイ

   終了日時 = Now
   MsgBox "処理時間は、" _
   & Format(終了日時 - 開始日時, "hh時間nn分ss秒") & " でした。"

End Sub


  '**********************************************************************
'  インストールされている Internet Explorer のバージョンを調べる
Private Sub IEバージョンを知る(バージョン)
   Dim IEバージョン 'As String
   Dim ファイルシステムオブジェクト 'As Object

   Set ファイルシステムオブジェクト = CreateObject("Scripting.FileSystemObject")

   IEバージョン = ファイルシステムオブジェクト.GetFileVersion _
   ("C:\Program Files\Internet Explorer\IEXPLORE.EXE ")
'  MsgBox IEバージョン

   バージョン = CInt(Left(IEバージョン, InStr(IEバージョン, ".") - 1))

   Set ファイルシステムオブジェクト = Nothing
End Sub

Option Explicit
Option Base 1

   Dim データ配列() As Variant
   Dim 過去の4本値配列(25, 7) As Variant
   Dim 標準偏差配列(100, 10) As Variant
   Dim 最終行数 As Integer
   Dim 処理行 As Integer
   Dim 対象URL As String
   Dim 日経URL As String
   Dim バージョン As String
   Dim IEオブジェクト As Object
   Dim 入力行 As Integer
   Dim 処理 As String
   Dim Shellオブジェクト As Object
   Dim 前回最終行 As Integer
   Dim HTMLソース As String
   Dim HTMLタイトル As String
   Dim 開始時刻 As Variant
   Dim 終了時刻 As Variant
   Dim 証券コード索引 As Object        'Scripting.Dictionary オブジェクト
   Dim 証券コード As String
   Dim 処理列 As Integer
   Dim 証券コード数 As Integer


Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
'これで Sleepを使ってミリ秒単位で処理にウェイトを入れることができます。


Sub 日経会社情報で株価標準偏差を取得する()

   開始時刻 = Now() 'マクロの処理時間を計測するため、開始時刻を取得

   '★証券コード索引を作成★
   Set 証券コード索引 = CreateObject("Scripting.Dictionary")  '★連想配列の定義

   ThisWorkbook.Worksheets("指定登録").Activate

   'シート「指定登録」の登録内容を、証券コード順に並び替え
   Range("A11").CurrentRegion.Sort _
      Key1:=Range("B11"), Order1:=xlAscending, _
      Key2:=Range("D11"), Order2:=xlDescending, _
      Header:=xlYes

   Call IEバージョンを知る(バージョン)   'IEのバージョンによって処理が変わるため

   'インターネット画面表示するためのデータを格納
   データ配列 = Range("A11").CurrentRegion.Value
   最終行数 = Cells(ActiveSheet.Rows.Count, 2).End(xlUp).Row '銘柄コードの列をベース
   日経URL = Range("I1").Value

   証券コード数 = 0

   '証券コード毎に、インターネットから情報を取得
   For 処理行 = 2 To 最終行数 - 9

      証券コード = データ配列(処理行, 2)

      If 証券コード索引.Exists(証券コード) = True Then

         '★既に4本値を取得済みの証券コードの場合
         ThisWorkbook.Worksheets("指定登録").Activate

         For 処理列 = 1 To 8
            Range("K1").Cells(処理行 + 9, 処理列).Value _
            = 標準偏差配列(証券コード索引(証券コード), 処理列)
         Next 処理列

         If Range("K1").Cells(処理行 + 9, 8).Value >= 0.05 Then '標準偏差が5%以上を水色に
            Range("K1").Cells(処理行 + 9, 8).Interior.ColorIndex = 8
            Range("C1").Cells(処理行 + 9, 1).Interior.ColorIndex = 8
         Else
            Range("K1").Cells(処理行 + 9, 8).Interior.ColorIndex = xlColorIndexNone
            Range("C1").Cells(処理行 + 9, 1).Interior.ColorIndex = xlColorIndexNone
         End If

         If Range("D1").Cells(処理行 + 9, 1).Value = "買" Then

            Range("F1").Cells(処理行 + 9, 1).Value _
            = 呼値(Int(Range("O1").Cells(処理行 + 9, 1).Value _
            + Range("L1").Cells(処理行 + 9, 1).Value * Val(Range("I1").Cells(処理行 + 9, 1).Value) + 0.5))
            '移動平均値に、標準偏差に指定倍数を掛けたものを加える。四捨五入して整数にする。

         ElseIf Range("D1").Cells(処理行 + 9, 1).Value = "売" Then
            Range("F1").Cells(処理行 + 9, 1).Value _
            = 呼値Int(Range("O1").Cells(処理行 + 9, 1).Value _
            + Range("L1").Cells(処理行 + 9, 1).Value * Val(Range("J1").Cells(処理行 + 9, 1).Value) + 0.5))
         End If

      Else

         'Shell.Applicationオブジェクトの作成
         Set Shellオブジェクト = CreateObject("Shell.Application")
         'IEオブジェクトの作成(ダミー)
         Set IEオブジェクト = CreateObject("InternetExplorer.Application")
         対象URL = 日経URL & 証券コード

         If バージョン > "6" Then
            IEオブジェクト.Navigate2 対象URL '★IE7の場合、既存or新しいウィンドウで表示される
            If 入力行 = 1 Then
               IEオブジェクト.Quit           '★IE7の場合、ここで閉じるのはCreateObjectで作成したウィンドウ
               Set IEオブジェクト = Nothing  '★IE7の場合、いったんオブジェクトをクリア
               Application.Wait Now + TimeValue("00:00:01")
            End If

            処理 = "Shell.ApplicationオブジェクトのWindowオブジェクトからIEオブジェクトを取り出す"
            '作成されているポイントは、Windowsコレクションの最後の要素

            Set IEオブジェクト = Shellオブジェクト.Windows.Item(Shellオブジェクト.Windows.Count - 1)
            'これ以降は、従来と同様の方法で操作が可能
            With IEオブジェクト
               .Navigate 対象URL
               .Visible = True
            End With

            Call IE表示待ち

         Else
            '★IE6以前の場合
            Set IEオブジェクト = CreateObject("InternetExplorer.Application")

            With IEオブジェクト
               .Navigate 対象URL
               .Visible = True
            End With

            Call IE表示待ち

         End If

         HTMLタイトル = ""
         HTMLソース = ""

         Do While HTMLソース = ""
            Sleep (1000)
            HTMLソース = IEオブジェクト.Document.Body.InnerHtml
         Loop

         HTMLタイトル = IEオブジェクト.LocationName

         Call 株価を取得してシートに貼付け 'ブラウザの画面から必要な項目を抽出して貼付けする

         IEオブジェクト.Quit

      End If

   Next 処理行

   'オブジェクトを破棄
   Set IEオブジェクト = Nothing


   'マクロの処理時間を表示して、マクロの終了を伝える
   終了時刻 = Now()
   MsgBox "処理が終了しました。" & Chr(13) _
   & "処理時間は、" & Format(終了時刻 - 開始時刻, "nn分ss秒") & " でした。", vbOKOnly

End Sub


Private Sub 株価を取得してシートに貼付け()
   Dim 文字配列
   Dim ページ行数 As Integer
   Dim 行文字列 As String
   Dim 行数 As Integer
   Dim 行カウンタ As Integer
   Dim 出力行数 As Integer
   Dim 出力列数 As Integer

   Erase 過去の4本値配列

   If Left(HTMLタイトル, 4) <> 証券コード Then '証券コードのデータが存在しない場合
      ThisWorkbook.Worksheets("指定登録").Activate
      Range("K1").Cells(処理行 + 9, 1).Value = "★証券コードの企業が存在しません★"
      ThisWorkbook.Worksheets("過去の4本値").Activate

   Else '証券コードのデータが存在した場合

      証券コード数 = 証券コード数 + 1

      If データ配列(処理行, 3) = "" Then '銘柄名が空白
         ThisWorkbook.Worksheets("指定登録").Activate

         Range("C1").Cells(処理行 + 9, 1).Value _
         = Trim(Mid(HTMLタイトル, 6, InStr(HTMLタイトル, "過去の4本値") - 6 - 1))
      End If

      ThisWorkbook.Worksheets("過去の4本値").Activate
      前回最終行 = Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row

      '前回取得の銘柄データを削除
      If 前回最終行 > 1 Then 'タイトル行のみの場合は消さないように
         Range("A2:G" & 前回最終行).ClearContents
      End If

      'ブラウザに表示されている内容を、1行ずつに分割
      文字配列 = Split(HTMLソース, vbNewLine)

      '全体行数を取得
      ページ行数 = UBound(文字配列)

      '取得行の絞込みに使うパラメータを初期化
      行カウンタ = 1

      '1行目から順に、最後の行まで
      For 行数 = 300 To ページ行数
         行文字列 = 文字配列(行数)

         'HTML から必要な項目を抽出するためのコーディングの情報を取得
         Debug.Print 行数
         Debug.Print 行文字列 'HTMLの内容を、イミディエイト・ウインドウに表示する

         If 行カウンタ = 1 Then
            If InStr(行文字列, "修正後終値") = 0 Then
               GoTo 次の行へ '「過去の4本値」に到達するまで読み飛ばす
            Else
               行カウンタ = 行数
            End If
         End If

         '検索結果の行数を取得
         If InStr(行文字列, "<TR>") > 0 Then
         ' 行データ開始
               出力行数 = 出力行数 + 1
               出力列数 = 0
         End If

         If 出力行数 > 0 And (InStr(行文字列, "<TD>") > 0 Or InStr(行文字列, "<TH>") > 0) Then
            '列データを配列に格納
            出力列数 = 出力列数 + 1
            If 出力列数 > 16 Then
               Exit For 'Body 読み込みを終わる
            End If

            過去の4本値配列(出力行数, 出力列数) = Trim(Replace(正規表現で置換("<(.*?)>", 行文字列, ""), " ", ""))

         End If

         If 出力行数 > 0 And InStr(行文字列, "</TABLE>") > 0 Then '検索結果のテーブルが終わった
            Exit For 'Body 読み込みを終わる。最後のセルと同一行に</TABLE>があるので、この位置で判定。
         End If
次の行へ:
      Next 行数 'html の Body データを一行ごとに読む

      Range("A2").Resize(25, 7).Value = 過去の4本値配列

      For 処理列 = 1 To 8
         標準偏差配列(証券コード数, 処理列) = Range("I2").Cells(1, 処理列).Value
      Next 処理列

      ThisWorkbook.Worksheets("指定登録").Activate
      For 処理列 = 1 To 8
         Range("K1").Cells(処理行 + 9, 処理列).Value _
         = 標準偏差配列(証券コード数, 処理列)
      Next 処理列

      If Range("K1").Cells(処理行 + 9, 8).Value >= 0.05 Then '標準偏差が5%以上を水色に
         Range("K1").Cells(処理行 + 9, 8).Interior.ColorIndex = 8
         Range("C1").Cells(処理行 + 9, 1).Interior.ColorIndex = 8
      Else
         Range("K1").Cells(処理行 + 9, 8).Interior.ColorIndex = xlColorIndexNone
         Range("C1").Cells(処理行 + 9, 1).Interior.ColorIndex = xlColorIndexNone
      End If


      証券コード索引(証券コード) = 証券コード数  '★取得済み証券コードとして索引に追加

      ThisWorkbook.Worksheets("指定登録").Activate

      If Range("D1").Cells(処理行 + 9, 1).Value = "買" Then
         Range("F1").Cells(処理行 + 9, 1).Value _
         = 呼値Int(Range("O1").Cells(処理行 + 9, 1).Value _
         + Range("L1").Cells(処理行 + 9, 1).Value * Val(Range("I1").Cells(処理行 + 9, 1).Value) + 0.5))
         '移動平均値に、標準偏差に指定倍数を掛けたものを加える。四捨五入して整数にする。

      ElseIf Range("D1").Cells(処理行 + 9, 1).Value = "売" Then
         Range("F1").Cells(処理行 + 9, 1).Value _
         = 呼値Int(Range("O1").Cells(処理行 + 9, 1).Value _
         + Range("L1").Cells(処理行 + 9, 1).Value * Val(Range("J1").Cells(処理行 + 9, 1).Value) + 0.5))
      End If

   End If

End Sub


Private Sub IE表示待ち()

   DoEvents       ' Sleep しているときに、画面を書き換えできるように、OS に制御を渡す。

   Do While IEオブジェクト.Busy = True Or IEオブジェクト.readystate <> 4
      Sleep (1000)
   Loop
   Sleep (2000)

End Sub

Function 呼値(価格 As Long) As Long

   Select Case 価格
      Case Is <= 3000
         呼値 = 価格
      Case Is <= 5000
         呼値 = 5 * Int(価格 / 5 + 0.5)
      Case Is <= 30000
         呼値 = 10 * Int(価格 / 10 + 0.5)
      Case Is <= 50000
         呼値 = 50 * Int(価格 / 50 + 0.5)
      Case Is <= 300000
         呼値 = 100 * Int(価格 / 100 + 0.5)
      Case Is <= 500000
         呼値 = 500 * Int(価格 / 500 + 0.5)
      Case Is <= 3000000
         呼値 = 1000 * Int(価格 / 1000 + 0.5)
      Case Is <= 5000000
         呼値 = 5000 * Int(価格 / 5000 + 0.5)
      Case Is <= 30000000
         呼値 = 10000 * Int(価格 / 10000 + 0.5)
      Case Is <= 50000000
         呼値 = 50000 * Int(価格 / 50000 + 0.5)
      Case Is > 50000000
         呼値 = 100000 * Int(価格 / 100000 + 0.5)
   End Select

End Function

Option Explicit

Sub 日経会社情報で適時開示速報を取得する()

   Const 日経URL As String = "https://www.nikkei.com/nkd/company/?scode="
   
   Dim 文字配列
   Dim ページ行数 As Integer
   Dim 行文字列 As String
   Dim 行数 As Integer
   Dim 行カウンタ As Integer
   Dim 対象URL As String


   対象URL = 日経URL & 証券コード
      
   '★★☆☆★★☆☆Web に接続して株価データを取得する☆☆★★☆☆★★
   HTMLソース = HTML取得(対象URL)
   '★★デバッグ用★★ debug用
   '         Call HTMLソースを出力 :     Stop
   '↑★★☆☆★★☆☆Web に接続して株価データを取得する☆☆★★☆☆★★
   
   'ブラウザに表示されている内容を、1行ずつに分割
   文字配列 = Split(HTMLソース, vbNewLine) '★★★ HTML の改行が vbNewLine の場合に対応 ★★★
   
   '全体行数を取得
   ページ行数 = UBound(文字配列)
   
   If ページ行数 = 0 Then
      Erase 文字配列
      文字配列 = Split(HTMLソース, vbLf) '★★★ HTML の改行が Lf の場合にも対応 ★★★
      '全体行数を取得
      ページ行数 = UBound(文字配列)
   End If
         
   '取得行の絞込みに使うパラメータを初期化
   行カウンタ = 1
   
   '1行目から順に、最後の行まで
   For 行数 = 200 To ページ行数
      行文字列 = 文字配列(行数)
      
      'HTML から必要な項目を抽出するためのコーディングの情報を取得
      Debug.Print 行数
      Debug.Print 行文字列 'HTMLの内容を、イミディエイト・ウインドウに表示する
'         If データ配列(処理行, 1) = 4502 Then Stop
      
      If 行カウンタ = 1 Then
         If InStr(行文字列, "適時開示速報") = 0 Then
            GoTo 次の行へ '「適時開示速報」の行に到達するまで読み飛ばす
         Else
            行カウンタ = 行数
         End If
      End If
         
      If InStr(行文字列, "m-st-top_timely_contents_new js-active m-newsList") > 0 And 行数 > 行カウンタ Then    '適時開示速報
         行数 = 行数 + 2
         行文字列 = 文字配列(行数)
         行文字列 = Replace(行文字列, " ", " ")
         行カウンタ = 行数
         
         ThisWorkbook.Worksheets("指定登録").Activate
         Range("AA1").Cells(処理行 + 9, 1).Value = Trim(正規表現で置換("<(.*?)>", 行文字列, ""))
         
         If Range("AA1").Cells(処理行 + 9, 1).Value <> Range("AB1").Cells(処理行 + 9, 1).Value Then
         '適時開示速報が既知で、株価に影響しないと思われる場合は、情報をセルABにコピーしておく。
         'この場合は、セルC1を赤色にはしない。
            
            If InStr(Range("AA1").Cells(処理行 + 9, 1).Value, "自己株式") > 0 _
            And InStr(Range("AA1").Cells(処理行 + 9, 1).Value, "取得終了") > 0 Then
               '問題ないので、色変えしない
            ElseIf InStr(Range("AA1").Cells(処理行 + 9, 1).Value, "注意") > 0 _
               Or InStr(Range("AA1").Cells(処理行 + 9, 1).Value, "監視") > 0 _
               Or InStr(Range("AA1").Cells(処理行 + 9, 1).Value, "銘柄") > 0 _
               Or InStr(Range("AA1").Cells(処理行 + 9, 1).Value, "希望退職") > 0 _
               Or InStr(Range("AA1").Cells(処理行 + 9, 1).Value, "特別損失") > 0 _
               Or InStr(Range("AA1").Cells(処理行 + 9, 1).Value, "終了") > 0 _
               Or InStr(Range("AA1").Cells(処理行 + 9, 1).Value, "子会社化") > 0 _
               Then
               Range("C1").Cells(処理行 + 9, 1).Interior.ColorIndex = 3 '赤色(自動発注の対象外にすべき？)
               Range("AA1").Cells(処理行 + 9, 1).Interior.ColorIndex = 3 '赤色(自動発注の対象外にすべき？)
            End If

         End If
         
         Exit For
         
      End If
次の行へ:
   Next 行数 'html の Body データを一行ごとに読む
   
End Sub

Option Explicit

   Dim コピー元ブック As Workbook
   Dim 銘柄コード As String
   
   Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
   'これで Sleepを使ってミリ秒単位で処理にウェイトを入れることができます。
   
Sub ブックの既存の全てのシートについて欠落セルデータをコピー()

   Dim コピー元ブックフルパス

   Dim 対象シート As Worksheet
   Dim 指定セル As Range
   Dim 開始日時     As Variant
   Dim 終了日時 As Variant

   Set 指定セル = Application.InputBox _
       (prompt:="コピー先ブックの、一つのシートの適当なセル、を選択してください" _
       , Title:="コピー先ファイルを指定" _
       , Type:=8)  ' 8は、セル参照 (Range オブジェクト)

   ' 指定セルの Range に対して、.Parent で親オブジェクトWorksheets を､
   ' その.Parent で、Workbooks を、取得します。

   If 指定セル.Parent.Parent.Name = ThisWorkbook.Name Then
       MsgBox "指定されたファイルは、このマクロのファイル自身です。" _
       & Chr(13) & "このままマクロを終了します。"
       Exit Sub
   End If

   開始日時 = Now                ' 開始時刻を変数に格納します。
   Application.DisplayStatusBar = True
   
   ' 処理を高速化するため、自動計算停止
   Application.Calculation = xlCalculationManual
   
   ThisWorkbook.Worksheets("Sheet1").Activate
   コピー元ブックフルパス = ThisWorkbook.Path & "\" & ThisWorkbook.Worksheets("Sheet1").Range("A2").Value
   
   Set コピー元ブック = Workbooks.Open(コピー元ブックフルパス)

   ' シート名を全て取得して、シート補完を実行
   
   指定セル.Parent.Activate

   For Each 対象シート In Worksheets
      銘柄コード = Left(対象シート.Name, 4)
      If IsNumeric(銘柄コード) = True Then
         対象シート.Activate
         Call シート補完
      End If
   Next
   
   コピー元ブック.Close savechanges:=False           '保存せずにブックを閉じる
   
   ' 自動計算停止解除
   Application.Calculation = xlCalculationAutomatic
   
   Application.StatusBar = False
   
   終了日時 = Now
   MsgBox "処理時間は、" _
   & Format(終了日時 - 開始日時, "hh時間nn分ss秒") & " でした。"
   
End Sub


Private Sub シート補完()

   Dim コピー元シート As Worksheet
   Dim 行数 As Integer
   Dim 列数 As Integer
   Dim 最終行 As Integer
   Dim 最終列 As Integer

   DoEvents       ' Sleep しているときに、画面を書き換えできるように、OS に制御を渡す。
   Sleep (1000)
   
   ' コピー元のブックのすべてのワークシートの名前を、For Each〜Nextで調べて照合します。
   For Each コピー元シート In コピー元ブック.Worksheets
      If 銘柄コード = Left(コピー元シート.Name, 4) Then
      
         With コピー元シート.UsedRange
            最終行 = .Find("*", , xlFormulas, , xlByRows, xlPrevious).Row
            最終列 = .Find("*", , xlFormulas, , xlByColumns, xlPrevious).Column
         End With
         
         For 行数 = 1 To 最終行
            Application.StatusBar = コピー元シート.Name & Space(2) & 行数
            
            For 列数 = 1 To 最終列
               If IsError(ActiveSheet.Range("A1").Cells(行数, 列数).Value) = False Then
                  If ActiveSheet.Range("A1").Cells(行数, 列数).Value = "" Then
                     If IsError(コピー元シート.Range("A1").Cells(行数, 列数).Value) = True Then
                     
                        ActiveSheet.Range("A1").Cells(行数, 列数).Value _
                        = コピー元シート.Range("A1").Cells(行数, 列数).Value
                        
                     ElseIf コピー元シート.Range("A1").Cells(行数, 列数).Value <> "" Then
                     
                        ActiveSheet.Range("A1").Cells(行数, 列数).Value _
                        = コピー元シート.Range("A1").Cells(行数, 列数).Value
                        
                     End If
                  End If
               End If
            
            Next 列数
         Next 行数
          
      End If
   Next

End Sub

Option Explicit

'2016/12/20：Yahoo のページ仕様変更に対応

Dim HTMLソース As String
      
Sub Yahooファイナンスコンセンサス予想取得()

   Const YahooURL As String = "https://kabuyoho.ifis.co.jp/index.php?id=100&action=tp1&sa=report&bcode="
   
   Dim 文字配列
   Dim ページ行数 As Integer
   Dim 行文字列 As String
   Dim 行数 As Integer

   Dim 対象URL As String

   Dim 正規表現 As RegExp
   Dim 正規表現アナリスト予想 As RegExp
   Dim 正規表現会社予想 As RegExp
   Dim Matchesコレクション As Object
   Dim Matchesコレクションアナリスト As Object
   Dim Matchesコレクション会社 As Object
   Dim 文字列 As String
   Dim HTMLタイトル As String
   
   Dim 経常利益会社予想 As Single
   Dim 経常利益アナリスト予想 As Single
   Dim 会社予想増益率 As Single
   Dim アナリスト予想増益率 As Single
   
   Dim 開始行 As Integer
   Dim 最終行数 As Integer
   

'*****************************************
   'HTML のタイトル抽出用
   Set 正規表現 = New RegExp
   With 正規表現
      .Pattern = "<title>.*</title>"
      .IgnoreCase = True '大文字小文字を区分しない
      .Global = False
   End With
'*****************************************
   Set 正規表現アナリスト予想 = New RegExp
'   アナリスト予想 (コンセンサス)</span><table><thead><tr><th class="none_left">日付</th><th class="em view_item">2016/12/19</th><th class="view_item">1週前</th><th class="none_right view_item">4週前</th></tr></thead><tbody><tr><th class="none_left">経常利益予想<br>増益率</th><td class="num_center em"><span class="num_b">18,300</span><br><span class="str_red">6.9 %<span></td>
   正規表現アナリスト予想.Pattern = "<span class=""str_b"">アナリスト予想 \(コンセンサス\)</span>.*?>([,\-0-9]+)<.*?>([,\-\.0-9]+) %<"
   正規表現アナリスト予想.Global = True
   
   Set 正規表現会社予想 = New RegExp
'   会社予想</span><table><thead><tr><th class="none_left none_right em">2016/11/07</th></tr></thead><tbody><tr><td class="none_left none_right em num_center"><span class="num_b"><span>21,000</span><br><span class="str_red">22.6 %<span></td>
   正規表現会社予想.Pattern = "<span class=""str_b"">会社予想</span>.*?>([,\-0-9]+)<.*?>([,\-\.0-9]+) %<"
   正規表現会社予想.Global = True
'*****************************************
   
   開始行 = 11 - 9
   最終行数 = Cells(ActiveSheet.Rows.Count, 2).End(xlUp).Row '銘柄コードの列をベース
   
   '証券コード毎に、インターネットから情報を取得
   For 処理行 = 開始行 To 最終行数 - 9
      証券コード = Range("B1").Cells(処理行 + 9, 1).Value
   
'*****************************************

   対象URL = YahooURL & 証券コード
   経常利益会社予想 = 0
   経常利益アナリスト予想 = 0
   会社予想増益率 = 0
   アナリスト予想増益率 = 0
   
   If Range("D1").Cells(処理行 + 9, 1).Value = "買" Then
         
      '★★☆☆★★☆☆Web に接続して経常利益アナリスト予想を取得する☆☆★★☆☆★★
      HTMLソース = HTML取得(対象URL)

      
      Set Matchesコレクション = 正規表現.Execute(HTMLソース)
      
      'HTML のタイトル抽出
      文字列 = Matchesコレクション(0).Value
      HTMLタイトル = Trim(正規表現で置換("<(.*?)>", 文字列, ""))
            
      If InStr(HTMLタイトル, 証券コード) = 0 Then '証券コードのデータが存在しない場合
         GoTo 次の行へ
      End If
      
      'ブラウザに表示されている内容を、正規表現で取得できるように1行にまとめる
      HTMLソース = Replace(HTMLソース, vbTab, "")                          'Tab を除外
      HTMLソース = Replace(HTMLソース, vbLf, "")                           '一旦改行を全て除外
      HTMLソース = Replace(HTMLソース, "</div>", "</div>" & vbCrLf)     '</div>の後に改行を入れる
      
   'デバッグ用 htmlソース書き出し
      '★★デバッグ用★★ debug用
'      If 証券コード = "8031" Then Call HTMLソースを出力
'               Stop
      '↑★★☆☆★★☆☆Web に接続して株価データを取得する☆☆★★☆☆★★

      Set Matchesコレクション会社 = 正規表現会社予想.Execute(HTMLソース)
      
      Range("AC1").Cells(処理行 + 9, 1).Value = Matchesコレクション会社.Item(0).SubMatches(0)
      If Range("AC1").Cells(処理行 + 9, 1).Value <> "--" Then
         経常利益会社予想 = Replace(Matchesコレクション会社.Item(0).SubMatches(0), ",", "")
      End If

      Range("AC1").Cells(処理行 + 10, 1).Value = Matchesコレクション会社.Item(0).SubMatches(1)
      If Range("AC1").Cells(処理行 + 10, 1).Value <> "--" Then
         会社予想増益率 = Replace(Matchesコレクション会社.Item(0).SubMatches(1), ",", "")
      End If


      Set Matchesコレクションアナリスト = 正規表現アナリスト予想.Execute(HTMLソース)
      
      Range("AD1").Cells(処理行 + 9, 1).Value = Matchesコレクションアナリスト.Item(0).SubMatches(0)
      If Range("AD1").Cells(処理行 + 9, 1).Value <> "--" Then
         経常利益アナリスト予想 = Matchesコレクションアナリスト.Item(0).SubMatches(0)
      End If
      
      Range("AD1").Cells(処理行 + 10, 1).Value = Matchesコレクションアナリスト.Item(0).SubMatches(1)
      If Range("AD1").Cells(処理行 + 10, 1).Value <> "--" Then
         アナリスト予想増益率 = Matchesコレクションアナリスト.Item(0).SubMatches(1)
      End If
      
      '通期予想が黒字で増加している場合は、買いの値を -2σまで狭める。
      If 経常利益アナリスト予想 > 0 And アナリスト予想増益率 > 0 Then
         If Val(Range("J1").Cells(処理行 + 9, 1).Value) < -2 Then
            Range("J1").Cells(処理行 + 9, 1).Value = "-2" & Right(Range("J1").Cells(処理行 + 9, 1).Value, 1)
         End If
'      ElseIf 経常利益会社予想 > 0 And 会社予想増益率 > 0 Then
'         If Val(Range("J1").Cells(処理行 + 9, 1).Value) < -2 Then
'            Range("J1").Cells(処理行 + 9, 1).Value = "-2" & Right(Range("J1").Cells(処理行 + 9, 1).Value, 1)
'         End If
      ElseIf Val(Range("J1").Cells(処理行 + 9, 1).Value) = -2 Then
      '通期予想が赤字かまたは減少している場合は、買いの値を -2σから -2.5σまで広げる。
            Range("J1").Cells(処理行 + 9, 1).Value = "-2.5" & Right(Range("J1").Cells(処理行 + 9, 1).Value, 1)
      End If
      
   End If
'*****************************************

次の行へ:
   Next 処理行
   
   ' 指定ファイルとオブジェクトをCLOSE
   Set 正規表現 = Nothing
   Set 正規表現アナリスト予想 = Nothing
   Set 正規表現会社予想 = Nothing
   Set Matchesコレクション = Nothing
   Set Matchesコレクションアナリスト = Nothing
   Set Matchesコレクション会社 = Nothing
   
   MsgBox "終了しました"
End Sub



Private Sub HTMLソースを出力()
'プログラムのチェック用として、所得した最後のHTMLソースをテキスト出力しておく

   Dim ファイルシステムオブジェクト As Object
   Dim 出力ファイルパス As String
   Dim キストストリームオブジェクト As Object
   
   Set ファイルシステムオブジェクト = CreateObject("Scripting.FileSystemObject")
   出力ファイルパス = ThisWorkbook.Path & "\" & "HTMLソース.txt"
   
   Set キストストリームオブジェクト = ファイルシステムオブジェクト.CreateTextFile(出力ファイルパス, True, True)
   キストストリームオブジェクト.writeLine HTMLソース

End Sub