三流君 ken3のmemo置き場

メモ置き場、保管庫として利用。まとまっていませんがヨロシク

挨拶・自己紹介:
失敗続きのAB型の変わり者 :三流プログラマー Ken3です
フリーのエンジニア・個人事業主です・・と書くと聞こえはイイが(それとなくカッコよく聞こえるが)、 現在は小さな案件の受注請負 と 短期派遣 で 日々つつましく?ほそぼそと暮らしてます。
(※詳細は[三流君 三流プログラマーとは?]を見てください)


広告:


[記事一覧、バックナンバーを見る]

コピペで作るプログラム と 変数とループを使ったプログラム

まぁ、たいした話じゃないのですが、
コピペでチョコチョコとパラメーターを変えて作成するプログラム

ループを使ったプログラムのお話です。

↓いつもの雑談動画 ぉぃぉぃ

www.youtube.com

単体のオッズを取得できたので、
次は、繰り返し、
1R-12Rまで、オッズを取得してみたいと思います。

1.コピペで縦に並べて作る
1Rが取得できたので、
次の2Rもソースをコピーして作る
※ぉぃぉぃ

下記7Rまでだけど、コピペで作成した クソプログラム ぉぃぉぃ

Sub ie_copy_pe()  'IEの表示をテストする。

'IEの起動
    Dim objIE As InternetExplorer '変数を定義します。
    Set objIE = CreateObject("InternetExplorer.Application") 'オブジェクトを作成します。
    objIE.Visible = True      '可視、Trueで見えるようにします。
    
'表示位置(左上の座標)とサイズ(高さ・幅)を調整する
    objIE.FullScreen = False '※Trueのモードだとびっくりするよ
    objIE.Top = 0      '左上 上位置
    objIE.Left = 0     '左上 左位置
    objIE.Width = 800    '横幅
    objIE.Height = 600   '高さ
    
'XXXバー、外観・外枠の調整。
    objIE.Toolbar = True     'タブの切り替えで必要なので、ツールバーを表示にする
    objIE.MenuBar = False    'メニューは非表示にする
    objIE.AddressBar = True  'URLなど アドレスバーは確認のため、表示する
    objIE.StatusBar = True   '一番下のステータスバーを表示。

'処理したいページを表示します。
    objIE.Navigate "http://www.jra.go.jp/"  '.Navigate メソッドで JRA表示する。
    'Navigate と Navigate2 の 違いが私もイマイチわかってませんが

'ページの表示完了を待ちます。
    While objIE.ReadyState <> READYSTATE_COMPLETE Or objIE.Busy = True '.ReadyState <> 4の間まわる。
        DoEvents  '重いので嫌いな人居るけど。
    Wend
    
'ページが表示されたので、表示された文章に対して、処理を行います。
    'HTML文章objIE.Documentからデータを取得
    '入力フォームDocument.Formsでデータをセットしたり送信したり
    'リンクDocument.Linksでリンクの情報を取得
    
        
    Dim i     As Integer '添え字 i番目などで使用
    Dim yLINE As Integer '行カウンタ、Y行目
    
    Dim oDocument As HTMLDocument
    Dim objA As HTMLAnchorElement
    
    Range("A1") = "調査したURLは " & strURL & " です"  'A1にURLを記述(セット)
    Range("D1") = "リンクの数は " & objIE.Document.Links.Length & "です"  'D1にリンクの数をセット

    Range("A2") = ".Href(リンク先)"   'A2~F2 2行目に見出しをセットする
    Range("B2") = ".OuterText"
    Range("C2") = ".OuterHTML"
    Range("D2") = ".InnerText"
    Range("E2") = ".InnerHTML"
    Range("F2") = ".Target"
    Columns("A:F").ColumnWidth = 22 '列幅を22に変更

    yLINE = 3  'セット開始の行を代入する
    For i = 0 To objIE.Document.Links.Length - 1
        'データをセルへセットする  'を付けて文字列にする(セルにセットしたいので)
        Cells(yLINE, "A") = "'" & objIE.Document.Links(i).href      'リンク先
        Cells(yLINE, "B") = "'" & objIE.Document.Links(i).outerText '自分を含む テキスト(Innerと変わりない?)
        Cells(yLINE, "C") = "'" & objIE.Document.Links(i).outerHTML '自分を含む HTML
        Cells(yLINE, "D") = "'" & objIE.Document.Links(i).innerText '内側のテキスト
        Cells(yLINE, "E") = "'" & objIE.Document.Links(i).innerHTML '内側のHTML
        Cells(yLINE, "F") = "'" & objIE.Document.Links(i).target    '_Blank や 表示先フレームの名前など
        
        'オッズを見つけたら クリック
        If InStr(objIE.Document.Links(i).innerHTML, "オッズ") > 0 Then '内側のHTML
            Set objA = objIE.Document.Links(i)  '見つけたAタグオブジェ(リンク)を代入
            objA.Click   'オッズを押す
            'objA.FireEvent ("onClick")  'onClick イベントを発行
            Exit For '見つけたのでループを抜ける
        End If
        yLINE = yLINE + 1 'セット位置(行)を+1する
    Next i

    '開催日を探す
'ページの表示完了を待ちます。
    While objIE.ReadyState <> READYSTATE_COMPLETE Or objIE.Busy = True '.ReadyState <> 4の間まわる。
        DoEvents  '重いので嫌いな人居るけど。
    Wend

    '開催日のリンクをあさる
    Range("A1") = "調査したURLは " & strURL & " です"  'A1にURLを記述(セット)
    Range("D1") = "リンクの数は " & objIE.Document.Links.Length & "です"  'D1にリンクの数をセット

    Range("A2") = ".Href(リンク先)"   'A2~F2 2行目に見出しをセットする
    Range("B2") = ".OuterText"
    Range("C2") = ".OuterHTML"
    Range("D2") = ".InnerText"
    Range("E2") = ".InnerHTML"
    Range("F2") = ".Target"
    Columns("A:F").ColumnWidth = 22 '列幅を22に変更

    yLINE = 3  'セット開始の行を代入する
    For i = 0 To objIE.Document.Links.Length - 1
         'データをセルへセットする  'を付けて文字列にする(セルにセットしたいので)
        Cells(yLINE, "A") = "'" & objIE.Document.Links(i).href      'リンク先
        Cells(yLINE, "B") = "'" & objIE.Document.Links(i).outerText '自分を含む テキスト(Innerと変わりない?)
        Cells(yLINE, "C") = "'" & objIE.Document.Links(i).outerHTML '自分を含む HTML
        Cells(yLINE, "D") = "'" & objIE.Document.Links(i).innerText '内側のテキスト
        Cells(yLINE, "E") = "'" & objIE.Document.Links(i).innerHTML '内側のHTML
        Cells(yLINE, "F") = "'" & objIE.Document.Links(i).target    '_Blank や 表示先フレームの名前など
        
        '開催日を見つけたら書き出す
        If Right(objIE.Document.Links(i).innerText, 1) = "日" Then '内側のTEXT
           
           Set objA = objIE.Document.Links(i)  '見つけたAタグオブジェ(リンク)を代入
           Debug.Print objA.innerText
           Debug.Print objA.innerHTML
          
           objA.Click   '開催日を押す
           
           Exit For '見つけたのでループを抜ける
        End If
        yLINE = yLINE + 1 'セット位置(行)を+1する

    Next i

'試しに1Rを取り込む
'ページの表示完了を待ちます。
    While objIE.ReadyState <> READYSTATE_COMPLETE Or objIE.Busy = True '.ReadyState <> 4の間まわる。
        DoEvents  '重いので嫌いな人居るけど。
    Wend

    For i = 0 To objIE.Document.Links.Length - 1
        
        '1Rを見つけたら クリック
        If InStr(objIE.Document.Links(i).innerHTML, """1R""") > 0 Then '内側のHTML
            Set objA = objIE.Document.Links(i)  '見つけたAタグオブジェ(リンク)を代入
            objA.Click   '1Rを押す
            'objA.FireEvent ("onClick")  'onClick イベントを発行
            Exit For '見つけたのでループを抜ける
        End If
    Next i

'単勝の表を取り込む
    'ページの表示完了を待ちます。
    While objIE.ReadyState <> READYSTATE_COMPLETE Or objIE.Busy = True '.ReadyState <> 4の間まわる。
        DoEvents  '重いので嫌いな人居るけど。
    Wend

    '表、テーブルを探る
   'テーブルを探す
    'タグの取出しが、.getElementsByTagName("TABLE")で 可能なので、
    Dim objTABLEs As Object 'TABLE複数の格納用
    Dim objTABLE As HTMLTable 'テーブル単体
    
    'TABLEタグを抜き 複数のテーブルをセット
    Set objTABLEs = objIE.Document.getElementsByTagName("TABLE")
    '↑で代入したオブジェクトからテーブルデータを取り出す。
    
    Set objTABLE = Nothing  'オブジェクトを空にする
    For i = 0 To objTABLEs.Length - 1  'テーブル数分回す
        If objTABLEs(i).Rows(0).Cells(0).innerText = "枠番" Then '左上が枠番を見つける
            Set objTABLE = objTABLEs(i)  'i盤目を代入
            Exit For
        End If
    Next i
    
    '↑で見つかったかチェックする
    If objTABLE Is Nothing Then
        MsgBox "枠番のテーブルが見つかりません"
        Exit Sub  'エラー表示して抜ける
    End If
    
    'まず、書き込み先シート、データをクリアする
    Cells.Delete Shift:=xlUp 'シート全体を削除する
    Range("A2").Select       '先頭A1を選択する、
    
    '表をDATAシートに書き出す
    Dim x As Integer  '列の管理
    Dim y As Integer  '行の管理
    
    Dim SET_Y As Integer
    Dim SET_X As Integer
    
    Dim objCELL As HTMLTableCell
    
    SET_Y = 2
    Cells(SET_Y - 1, 1) = "1R"
    
    'Webの表をシートへ転記(代入する)
    For y = 0 To objTABLE.Rows.Length - 1  '行のループ
        SET_X = 1
        For x = 0 To objTABLE.Rows(y).Cells.Length - 1  '列数分ループ
            ' objTABLE.rows(行).cells(列)
            Set objCELL = objTABLE.Rows(y).Cells(x)
            
            If objCELL.rowSpan > 1 Then  '縦に複数の時
                Cells(SET_Y + 1, SET_X) = objCELL.innerText  '下にも同じくセット
            End If
                        
            '既にデータありか、縦に結合されているか?
            If Len(Trim("" & Cells(SET_Y, SET_X))) > 0 Then
                SET_X = SET_X + 1
            End If
            
            Cells(SET_Y, SET_X) = objCELL.innerText  'データセット
            
            '横に結合されているか判断
            SET_X = SET_X + objCELL.colSpan  'カラム分 横に移動
        Next
        SET_Y = SET_Y + 1
    Next



'copy
'試しに2Rを取り込む

    For i = 0 To objIE.Document.Links.Length - 1
        
        '1Rを見つけたら クリック
        If InStr(objIE.Document.Links(i).innerHTML, """2R""") > 0 Then '内側のHTML
            Set objA = objIE.Document.Links(i)  '見つけたAタグオブジェ(リンク)を代入
            objA.Click   '1Rを押す
            'objA.FireEvent ("onClick")  'onClick イベントを発行
            Exit For '見つけたのでループを抜ける
        End If
    Next i

'単勝の表を取り込む
    'ページの表示完了を待ちます。
    While objIE.ReadyState <> READYSTATE_COMPLETE Or objIE.Busy = True '.ReadyState <> 4の間まわる。
        DoEvents  '重いので嫌いな人居るけど。
    Wend

    '表、テーブルを探る
   'テーブルを探す
    'タグの取出しが、.getElementsByTagName("TABLE")で 可能なので、
    'TABLEタグを抜き 複数のテーブルをセット
    Set objTABLEs = objIE.Document.getElementsByTagName("TABLE")
    '↑で代入したオブジェクトからテーブルデータを取り出す。
    
    Set objTABLE = Nothing  'オブジェクトを空にする
    For i = 0 To objTABLEs.Length - 1  'テーブル数分回す
        If objTABLEs(i).Rows(0).Cells(0).innerText = "枠番" Then '左上が枠番を見つける
            Set objTABLE = objTABLEs(i)  'i盤目を代入
            Exit For
        End If
    Next i
    
    '↑で見つかったかチェックする
    If objTABLE Is Nothing Then
        MsgBox "枠番のテーブルが見つかりません"
        Exit Sub  'エラー表示して抜ける
    End If
    
    
    '表をDATAシートに書き出す
    
    SET_Y = SET_Y + 2
    Cells(SET_Y - 1, 1) = "2R"
    
    'Webの表をシートへ転記(代入する)
    For y = 0 To objTABLE.Rows.Length - 1  '行のループ
        SET_X = 1
        For x = 0 To objTABLE.Rows(y).Cells.Length - 1  '列数分ループ
            ' objTABLE.rows(行).cells(列)
            Set objCELL = objTABLE.Rows(y).Cells(x)
            
            If objCELL.rowSpan > 1 Then  '縦に複数の時
                Cells(SET_Y + 1, SET_X) = objCELL.innerText  '下にも同じくセット
            End If
                        
            '既にデータありか、縦に結合されているか?
            If Len(Trim("" & Cells(SET_Y, SET_X))) > 0 Then
                SET_X = SET_X + 1
            End If
            
            Cells(SET_Y, SET_X) = objCELL.innerText  'データセット
            
            '横に結合されているか判断
            SET_X = SET_X + objCELL.colSpan  'カラム分 横に移動
        Next
        SET_Y = SET_Y + 1
    Next

'copy
'試しに3Rを取り込む

    For i = 0 To objIE.Document.Links.Length - 1
        
        '1Rを見つけたら クリック
        If InStr(objIE.Document.Links(i).innerHTML, """3R""") > 0 Then '内側のHTML
            Set objA = objIE.Document.Links(i)  '見つけたAタグオブジェ(リンク)を代入
            objA.Click   '1Rを押す
            'objA.FireEvent ("onClick")  'onClick イベントを発行
            Exit For '見つけたのでループを抜ける
        End If
    Next i

'単勝の表を取り込む
    'ページの表示完了を待ちます。
    While objIE.ReadyState <> READYSTATE_COMPLETE Or objIE.Busy = True '.ReadyState <> 4の間まわる。
        DoEvents  '重いので嫌いな人居るけど。
    Wend

    '表、テーブルを探る
   'テーブルを探す
    'タグの取出しが、.getElementsByTagName("TABLE")で 可能なので、
    'TABLEタグを抜き 複数のテーブルをセット
    Set objTABLEs = objIE.Document.getElementsByTagName("TABLE")
    '↑で代入したオブジェクトからテーブルデータを取り出す。
    
    Set objTABLE = Nothing  'オブジェクトを空にする
    For i = 0 To objTABLEs.Length - 1  'テーブル数分回す
        If objTABLEs(i).Rows(0).Cells(0).innerText = "枠番" Then '左上が枠番を見つける
            Set objTABLE = objTABLEs(i)  'i盤目を代入
            Exit For
        End If
    Next i
    
    '↑で見つかったかチェックする
    If objTABLE Is Nothing Then
        MsgBox "枠番のテーブルが見つかりません"
        Exit Sub  'エラー表示して抜ける
    End If
    
    
    '表をDATAシートに書き出す
    
    SET_Y = SET_Y + 2
    Cells(SET_Y - 1, 1) = "3R"
    
    'Webの表をシートへ転記(代入する)
    For y = 0 To objTABLE.Rows.Length - 1  '行のループ
        SET_X = 1
        For x = 0 To objTABLE.Rows(y).Cells.Length - 1  '列数分ループ
            ' objTABLE.rows(行).cells(列)
            Set objCELL = objTABLE.Rows(y).Cells(x)
            
            If objCELL.rowSpan > 1 Then  '縦に複数の時
                Cells(SET_Y + 1, SET_X) = objCELL.innerText  '下にも同じくセット
            End If
                        
            '既にデータありか、縦に結合されているか?
            If Len(Trim("" & Cells(SET_Y, SET_X))) > 0 Then
                SET_X = SET_X + 1
            End If
            
            Cells(SET_Y, SET_X) = objCELL.innerText  'データセット
            
            '横に結合されているか判断
            SET_X = SET_X + objCELL.colSpan  'カラム分 横に移動
        Next
        SET_Y = SET_Y + 1
    Next

'copy
'試しに4Rを取り込む

    For i = 0 To objIE.Document.Links.Length - 1
        
        '1Rを見つけたら クリック
        If InStr(objIE.Document.Links(i).innerHTML, """4R""") > 0 Then '内側のHTML
            Set objA = objIE.Document.Links(i)  '見つけたAタグオブジェ(リンク)を代入
            objA.Click   '1Rを押す
            'objA.FireEvent ("onClick")  'onClick イベントを発行
            Exit For '見つけたのでループを抜ける
        End If
    Next i

'単勝の表を取り込む
    'ページの表示完了を待ちます。
    While objIE.ReadyState <> READYSTATE_COMPLETE Or objIE.Busy = True '.ReadyState <> 4の間まわる。
        DoEvents  '重いので嫌いな人居るけど。
    Wend

    '表、テーブルを探る
   'テーブルを探す
    'タグの取出しが、.getElementsByTagName("TABLE")で 可能なので、
    'TABLEタグを抜き 複数のテーブルをセット
    Set objTABLEs = objIE.Document.getElementsByTagName("TABLE")
    '↑で代入したオブジェクトからテーブルデータを取り出す。
    
    Set objTABLE = Nothing  'オブジェクトを空にする
    For i = 0 To objTABLEs.Length - 1  'テーブル数分回す
        If objTABLEs(i).Rows(0).Cells(0).innerText = "枠番" Then '左上が枠番を見つける
            Set objTABLE = objTABLEs(i)  'i盤目を代入
            Exit For
        End If
    Next i
    
    '↑で見つかったかチェックする
    If objTABLE Is Nothing Then
        MsgBox "枠番のテーブルが見つかりません"
        Exit Sub  'エラー表示して抜ける
    End If
    
    
    '表をDATAシートに書き出す
    
    SET_Y = SET_Y + 2
    Cells(SET_Y - 1, 1) = "4R"
    
    'Webの表をシートへ転記(代入する)
    For y = 0 To objTABLE.Rows.Length - 1  '行のループ
        SET_X = 1
        For x = 0 To objTABLE.Rows(y).Cells.Length - 1  '列数分ループ
            ' objTABLE.rows(行).cells(列)
            Set objCELL = objTABLE.Rows(y).Cells(x)
            
            If objCELL.rowSpan > 1 Then  '縦に複数の時
                Cells(SET_Y + 1, SET_X) = objCELL.innerText  '下にも同じくセット
            End If
                        
            '既にデータありか、縦に結合されているか?
            If Len(Trim("" & Cells(SET_Y, SET_X))) > 0 Then
                SET_X = SET_X + 1
            End If
            
            Cells(SET_Y, SET_X) = objCELL.innerText  'データセット
            
            '横に結合されているか判断
            SET_X = SET_X + objCELL.colSpan  'カラム分 横に移動
        Next
        SET_Y = SET_Y + 1
    Next


'copy
'試しに5Rを取り込む

    For i = 0 To objIE.Document.Links.Length - 1
        
        '1Rを見つけたら クリック
        If InStr(objIE.Document.Links(i).innerHTML, """5R""") > 0 Then '内側のHTML
            Set objA = objIE.Document.Links(i)  '見つけたAタグオブジェ(リンク)を代入
            objA.Click   '1Rを押す
            'objA.FireEvent ("onClick")  'onClick イベントを発行
            Exit For '見つけたのでループを抜ける
        End If
    Next i

'単勝の表を取り込む
    'ページの表示完了を待ちます。
    While objIE.ReadyState <> READYSTATE_COMPLETE Or objIE.Busy = True '.ReadyState <> 4の間まわる。
        DoEvents  '重いので嫌いな人居るけど。
    Wend

    '表、テーブルを探る
   'テーブルを探す
    'タグの取出しが、.getElementsByTagName("TABLE")で 可能なので、
    'TABLEタグを抜き 複数のテーブルをセット
    Set objTABLEs = objIE.Document.getElementsByTagName("TABLE")
    '↑で代入したオブジェクトからテーブルデータを取り出す。
    
    Set objTABLE = Nothing  'オブジェクトを空にする
    For i = 0 To objTABLEs.Length - 1  'テーブル数分回す
        If objTABLEs(i).Rows(0).Cells(0).innerText = "枠番" Then '左上が枠番を見つける
            Set objTABLE = objTABLEs(i)  'i盤目を代入
            Exit For
        End If
    Next i
    
    '↑で見つかったかチェックする
    If objTABLE Is Nothing Then
        MsgBox "枠番のテーブルが見つかりません"
        Exit Sub  'エラー表示して抜ける
    End If
    
    
    '表をDATAシートに書き出す
    
    SET_Y = SET_Y + 2
    Cells(SET_Y - 1, 1) = "5R"
    
    'Webの表をシートへ転記(代入する)
    For y = 0 To objTABLE.Rows.Length - 1  '行のループ
        SET_X = 1
        For x = 0 To objTABLE.Rows(y).Cells.Length - 1  '列数分ループ
            ' objTABLE.rows(行).cells(列)
            Set objCELL = objTABLE.Rows(y).Cells(x)
            
            If objCELL.rowSpan > 1 Then  '縦に複数の時
                Cells(SET_Y + 1, SET_X) = objCELL.innerText  '下にも同じくセット
            End If
                        
            '既にデータありか、縦に結合されているか?
            If Len(Trim("" & Cells(SET_Y, SET_X))) > 0 Then
                SET_X = SET_X + 1
            End If
            
            Cells(SET_Y, SET_X) = objCELL.innerText  'データセット
            
            '横に結合されているか判断
            SET_X = SET_X + objCELL.colSpan  'カラム分 横に移動
        Next
        SET_Y = SET_Y + 1
    Next

'copy
'試しに6Rを取り込む

    For i = 0 To objIE.Document.Links.Length - 1
        
        '1Rを見つけたら クリック
        If InStr(objIE.Document.Links(i).innerHTML, """6R""") > 0 Then '内側のHTML
            Set objA = objIE.Document.Links(i)  '見つけたAタグオブジェ(リンク)を代入
            objA.Click   '1Rを押す
            'objA.FireEvent ("onClick")  'onClick イベントを発行
            Exit For '見つけたのでループを抜ける
        End If
    Next i

'単勝の表を取り込む
    'ページの表示完了を待ちます。
    While objIE.ReadyState <> READYSTATE_COMPLETE Or objIE.Busy = True '.ReadyState <> 4の間まわる。
        DoEvents  '重いので嫌いな人居るけど。
    Wend

    '表、テーブルを探る
   'テーブルを探す
    'タグの取出しが、.getElementsByTagName("TABLE")で 可能なので、
    'TABLEタグを抜き 複数のテーブルをセット
    Set objTABLEs = objIE.Document.getElementsByTagName("TABLE")
    '↑で代入したオブジェクトからテーブルデータを取り出す。
    
    Set objTABLE = Nothing  'オブジェクトを空にする
    For i = 0 To objTABLEs.Length - 1  'テーブル数分回す
        If objTABLEs(i).Rows(0).Cells(0).innerText = "枠番" Then '左上が枠番を見つける
            Set objTABLE = objTABLEs(i)  'i盤目を代入
            Exit For
        End If
    Next i
    
    '↑で見つかったかチェックする
    If objTABLE Is Nothing Then
        MsgBox "枠番のテーブルが見つかりません"
        Exit Sub  'エラー表示して抜ける
    End If
    
    
    '表をDATAシートに書き出す
    
    SET_Y = SET_Y + 2
    Cells(SET_Y - 1, 1) = "6R"
    
    'Webの表をシートへ転記(代入する)
    For y = 0 To objTABLE.Rows.Length - 1  '行のループ
        SET_X = 1
        For x = 0 To objTABLE.Rows(y).Cells.Length - 1  '列数分ループ
            ' objTABLE.rows(行).cells(列)
            Set objCELL = objTABLE.Rows(y).Cells(x)
            
            If objCELL.rowSpan > 1 Then  '縦に複数の時
                Cells(SET_Y + 1, SET_X) = objCELL.innerText  '下にも同じくセット
            End If
                        
            '既にデータありか、縦に結合されているか?
            If Len(Trim("" & Cells(SET_Y, SET_X))) > 0 Then
                SET_X = SET_X + 1
            End If
            
            Cells(SET_Y, SET_X) = objCELL.innerText  'データセット
            
            '横に結合されているか判断
            SET_X = SET_X + objCELL.colSpan  'カラム分 横に移動
        Next
        SET_Y = SET_Y + 1
    Next

'copy
'試しに7Rを取り込む

    For i = 0 To objIE.Document.Links.Length - 1
        
        '1Rを見つけたら クリック
        If InStr(objIE.Document.Links(i).innerHTML, """7R""") > 0 Then '内側のHTML
            Set objA = objIE.Document.Links(i)  '見つけたAタグオブジェ(リンク)を代入
            objA.Click   '1Rを押す
            'objA.FireEvent ("onClick")  'onClick イベントを発行
            Exit For '見つけたのでループを抜ける
        End If
    Next i

'単勝の表を取り込む
    'ページの表示完了を待ちます。
    While objIE.ReadyState <> READYSTATE_COMPLETE Or objIE.Busy = True '.ReadyState <> 4の間まわる。
        DoEvents  '重いので嫌いな人居るけど。
    Wend

    '表、テーブルを探る
   'テーブルを探す
    'タグの取出しが、.getElementsByTagName("TABLE")で 可能なので、
    'TABLEタグを抜き 複数のテーブルをセット
    Set objTABLEs = objIE.Document.getElementsByTagName("TABLE")
    '↑で代入したオブジェクトからテーブルデータを取り出す。
    
    Set objTABLE = Nothing  'オブジェクトを空にする
    For i = 0 To objTABLEs.Length - 1  'テーブル数分回す
        If objTABLEs(i).Rows(0).Cells(0).innerText = "枠番" Then '左上が枠番を見つける
            Set objTABLE = objTABLEs(i)  'i盤目を代入
            Exit For
        End If
    Next i
    
    '↑で見つかったかチェックする
    If objTABLE Is Nothing Then
        MsgBox "枠番のテーブルが見つかりません"
        Exit Sub  'エラー表示して抜ける
    End If
    
    
    '表をDATAシートに書き出す
    
    SET_Y = SET_Y + 2
    Cells(SET_Y - 1, 1) = "7R"
    
    'Webの表をシートへ転記(代入する)
    For y = 0 To objTABLE.Rows.Length - 1  '行のループ
        SET_X = 1
        For x = 0 To objTABLE.Rows(y).Cells.Length - 1  '列数分ループ
            ' objTABLE.rows(行).cells(列)
            Set objCELL = objTABLE.Rows(y).Cells(x)
            
            If objCELL.rowSpan > 1 Then  '縦に複数の時
                Cells(SET_Y + 1, SET_X) = objCELL.innerText  '下にも同じくセット
            End If
                        
            '既にデータありか、縦に結合されているか?
            If Len(Trim("" & Cells(SET_Y, SET_X))) > 0 Then
                SET_X = SET_X + 1
            End If
            
            Cells(SET_Y, SET_X) = objCELL.innerText  'データセット
            
            '横に結合されているか判断
            SET_X = SET_X + objCELL.colSpan  'カラム分 横に移動
        Next
        SET_Y = SET_Y + 1
    Next





'処理が終わったので、IEを閉じます。
    'テストの時は、↓確認して、残しておくと便利ですよ。
    If MsgBox("IEを閉じますか?", vbYesNo) = vbYes Then '終了確認
        objIE.Quit  '.Quitで閉じる
    End If
    
    Set objIE = Nothing '使用したオブジェクト変数もキレイにしてね。
   
End Sub

2.雑談

嫌いな先輩や上司に小言を言われたので、
むかついたから 作っちゃったよ
そんな
負のマイナスエネルギーをやる気に変える人達?
動画で、雑談を はさみつつ、

f:id:ken3memo:20170716045306j:plain

3.同じ処理は変数にして、ループでまわしましょ・・
まぁ、通常は
メンテもしやすいし、同じ処理はまとめましょう・・・

Sub ie_test()  'IEの表示をテストする。

'IEの起動
    Dim objIE As InternetExplorer '変数を定義します。
    Set objIE = CreateObject("InternetExplorer.Application") 'オブジェクトを作成します。
    objIE.Visible = True      '可視、Trueで見えるようにします。
    
'表示位置(左上の座標)とサイズ(高さ・幅)を調整する
    objIE.FullScreen = False '※Trueのモードだとびっくりするよ
    objIE.Top = 0      '左上 上位置
    objIE.Left = 0     '左上 左位置
    objIE.Width = 800    '横幅
    objIE.Height = 600   '高さ
    
'XXXバー、外観・外枠の調整。
    objIE.Toolbar = True     'タブの切り替えで必要なので、ツールバーを表示にする
    objIE.MenuBar = False    'メニューは非表示にする
    objIE.AddressBar = True  'URLなど アドレスバーは確認のため、表示する
    objIE.StatusBar = True   '一番下のステータスバーを表示。

'処理したいページを表示します。
    objIE.Navigate "http://www.jra.go.jp/"  '.Navigate メソッドで JRA表示する。
    'Navigate と Navigate2 の 違いが私もイマイチわかってませんが

'ページの表示完了を待ちます。
    While objIE.ReadyState <> READYSTATE_COMPLETE Or objIE.Busy = True '.ReadyState <> 4の間まわる。
        DoEvents  '重いので嫌いな人居るけど。
    Wend
    
'ページが表示されたので、表示された文章に対して、処理を行います。
    'HTML文章objIE.Documentからデータを取得
    '入力フォームDocument.Formsでデータをセットしたり送信したり
    'リンクDocument.Linksでリンクの情報を取得
    
        
    Dim i     As Integer '添え字 i番目などで使用
    Dim yLINE As Integer '行カウンタ、Y行目
    
    Dim oDocument As HTMLDocument
    Dim objA As HTMLAnchorElement
    
    Range("A1") = "調査したURLは " & strURL & " です"  'A1にURLを記述(セット)
    Range("D1") = "リンクの数は " & objIE.Document.Links.Length & "です"  'D1にリンクの数をセット

    Range("A2") = ".Href(リンク先)"   'A2~F2 2行目に見出しをセットする
    Range("B2") = ".OuterText"
    Range("C2") = ".OuterHTML"
    Range("D2") = ".InnerText"
    Range("E2") = ".InnerHTML"
    Range("F2") = ".Target"
    Columns("A:F").ColumnWidth = 22 '列幅を22に変更

    yLINE = 3  'セット開始の行を代入する
    For i = 0 To objIE.Document.Links.Length - 1
        'データをセルへセットする  'を付けて文字列にする(セルにセットしたいので)
        Cells(yLINE, "A") = "'" & objIE.Document.Links(i).href      'リンク先
        Cells(yLINE, "B") = "'" & objIE.Document.Links(i).outerText '自分を含む テキスト(Innerと変わりない?)
        Cells(yLINE, "C") = "'" & objIE.Document.Links(i).outerHTML '自分を含む HTML
        Cells(yLINE, "D") = "'" & objIE.Document.Links(i).innerText '内側のテキスト
        Cells(yLINE, "E") = "'" & objIE.Document.Links(i).innerHTML '内側のHTML
        Cells(yLINE, "F") = "'" & objIE.Document.Links(i).target    '_Blank や 表示先フレームの名前など
        
        'オッズを見つけたら クリック
        If InStr(objIE.Document.Links(i).innerHTML, "オッズ") > 0 Then '内側のHTML
            Set objA = objIE.Document.Links(i)  '見つけたAタグオブジェ(リンク)を代入
            objA.Click   'オッズを押す
            'objA.FireEvent ("onClick")  'onClick イベントを発行
            Exit For '見つけたのでループを抜ける
        End If
        yLINE = yLINE + 1 'セット位置(行)を+1する
    Next i

    '開催日を探す
'ページの表示完了を待ちます。
    While objIE.ReadyState <> READYSTATE_COMPLETE Or objIE.Busy = True '.ReadyState <> 4の間まわる。
        DoEvents  '重いので嫌いな人居るけど。
    Wend

    '開催日のリンクをあさる
    Range("A1") = "調査したURLは " & strURL & " です"  'A1にURLを記述(セット)
    Range("D1") = "リンクの数は " & objIE.Document.Links.Length & "です"  'D1にリンクの数をセット

    Range("A2") = ".Href(リンク先)"   'A2~F2 2行目に見出しをセットする
    Range("B2") = ".OuterText"
    Range("C2") = ".OuterHTML"
    Range("D2") = ".InnerText"
    Range("E2") = ".InnerHTML"
    Range("F2") = ".Target"
    Columns("A:F").ColumnWidth = 22 '列幅を22に変更

    yLINE = 3  'セット開始の行を代入する
    For i = 0 To objIE.Document.Links.Length - 1
         'データをセルへセットする  'を付けて文字列にする(セルにセットしたいので)
        Cells(yLINE, "A") = "'" & objIE.Document.Links(i).href      'リンク先
        Cells(yLINE, "B") = "'" & objIE.Document.Links(i).outerText '自分を含む テキスト(Innerと変わりない?)
        Cells(yLINE, "C") = "'" & objIE.Document.Links(i).outerHTML '自分を含む HTML
        Cells(yLINE, "D") = "'" & objIE.Document.Links(i).innerText '内側のテキスト
        Cells(yLINE, "E") = "'" & objIE.Document.Links(i).innerHTML '内側のHTML
        Cells(yLINE, "F") = "'" & objIE.Document.Links(i).target    '_Blank や 表示先フレームの名前など
        
        '開催日を見つけたら書き出す
        If Right(objIE.Document.Links(i).innerText, 1) = "日" Then '内側のTEXT
           
           Set objA = objIE.Document.Links(i)  '見つけたAタグオブジェ(リンク)を代入
           Debug.Print objA.innerText
           Debug.Print objA.innerHTML
          
           objA.Click   '開催日を押す
           
           Exit For '見つけたのでループを抜ける
        End If
        yLINE = yLINE + 1 'セット位置(行)を+1する

    Next i

'試しに1Rを取り込む
'ページの表示完了を待ちます。
    While objIE.ReadyState <> READYSTATE_COMPLETE Or objIE.Busy = True '.ReadyState <> 4の間まわる。
        DoEvents  '重いので嫌いな人居るけど。
    Wend


'1R-12R
    
    Dim objTABLEs As Object 'TABLE複数の格納用
    Dim objTABLE As HTMLTable 'テーブル単体
    
    Dim x As Integer  '列の管理
    Dim y As Integer  '行の管理
    
    Dim SET_Y As Integer
    Dim SET_X As Integer
    
    Dim objCELL As HTMLTableCell

Dim nRACE As Integer
Dim strRACE As String

    'まず、書き込み先シート、データをクリアする
    Cells.Delete Shift:=xlUp 'シート全体を削除する
    Range("A1").Select       '先頭A1を選択する、

    SET_Y = 0  'セット位置を初期化

For nRACE = 1 To 12  '一から十二まで
    
    strRACE = nRACE & "R"   'R1など 文字にする

    'レース番号をセルに書く
    SET_Y = SET_Y + 1
    Cells(SET_Y, 1) = strRACE
    SET_Y = SET_Y + 1
    
    For i = 0 To objIE.Document.Links.Length - 1
        
        '"1R"を見つけたら クリック
        If InStr(objIE.Document.Links(i).innerHTML, """" & strRACE & """") > 0 Then '内側のHTML
            Set objA = objIE.Document.Links(i)  '見つけたAタグオブジェ(リンク)を代入
            objA.Click   '1Rを押す
            'objA.FireEvent ("onClick")  'onClick イベントを発行
            Exit For '見つけたのでループを抜ける
        End If
    Next i

'単勝の表を取り込む
    'ページの表示完了を待ちます。
    While objIE.ReadyState <> READYSTATE_COMPLETE Or objIE.Busy = True '.ReadyState <> 4の間まわる。
        DoEvents  '重いので嫌いな人居るけど。
    Wend

    '表、テーブルを探る
   'テーブルを探す
    'タグの取出しが、.getElementsByTagName("TABLE")で 可能なので、
    
    'TABLEタグを抜き 複数のテーブルをセット
    Set objTABLEs = objIE.Document.getElementsByTagName("TABLE")
    '↑で代入したオブジェクトからテーブルデータを取り出す。
    
    Set objTABLE = Nothing  'オブジェクトを空にする
    For i = 0 To objTABLEs.Length - 1  'テーブル数分回す
        If objTABLEs(i).Rows(0).Cells(0).innerText = "枠番" Then '左上が枠番を見つける
            Set objTABLE = objTABLEs(i)  'i盤目を代入
            Exit For
        End If
    Next i
    
    '↑で見つかったかチェックする
    If objTABLE Is Nothing Then
        MsgBox "枠番のテーブルが見つかりません"
        Exit Sub  'エラー表示して抜ける
    End If
    
    
    '表をDATAシートに書き出す
    
    'Webの表をシートへ転記(代入する)
    For y = 0 To objTABLE.Rows.Length - 1  '行のループ
        SET_X = 1
        For x = 0 To objTABLE.Rows(y).Cells.Length - 1  '列数分ループ
            ' objTABLE.rows(行).cells(列)
            Set objCELL = objTABLE.Rows(y).Cells(x)
            
            If objCELL.rowSpan > 1 Then  '縦に複数の時
                Cells(SET_Y + 1, SET_X) = objCELL.innerText  '下にも同じくセット
            End If
                        
            '既にデータありか、縦に結合されているか?
            If Len(Trim("" & Cells(SET_Y, SET_X))) > 0 Then
                SET_X = SET_X + 1
            End If
            
            Cells(SET_Y, SET_X) = objCELL.innerText  'データセット
            
            '横に結合されているか判断
            SET_X = SET_X + objCELL.colSpan  'カラム分 横に移動
        Next
        SET_Y = SET_Y + 1
    Next
    SET_Y = SET_Y + 1  '空白を一行追加
Next


'処理が終わったので、IEを閉じます。
    'テストの時は、↓確認して、残しておくと便利ですよ。
    If MsgBox("IEを閉じますか?", vbYesNo) = vbYes Then '終了確認
        objIE.Quit  '.Quitで閉じる
    End If
    
    Set objIE = Nothing '使用したオブジェクト変数もキレイにしてね。
   
End Sub


↓※冒頭と同じ いつもの雑談動画 ぉぃぉぃ

www.youtube.com


雑談がむごいけど、こんな感じで極端な違いを感じ取ってもらえれば・・・




三流君へ メッセージを送る

全ての質問に答えることはできませんが、
ダメもとで、気軽に質問、感想、メッセージを送ってくださいね・・・

感想や質問・要望・苦情など 三流君へメッセージを送る。
下記のフォームからメッセージを送ることができます。


あなたのお名前(ニックネーム):さん
返信は?:

アドレス:に返事をもらいたい
感想や質問↓:


(感想や質問・要望・苦情はHPで記事に載せることがあります。)
例:[XXXXさんへ回答例]←みたいに回答していたり...


Ken3 ホームページ 目次

分類:HPを大きく分けると4つの柱(分類)です。
・[Excel/Access VBA]の解説
・[ASP(Active Server Pages)]の解説。
・[元コンビニ店長時代の話]が弟に巻き込まれ、失敗した脱サラ、畑違い?の仕事で失敗。
・[プログラマーの愚痴]では、あまり見せたくない三流プログラマーの内面かな。
三流君を踏み台にする
主に上記4つの分類でHP作成やメルマガの発行を行ってます。
※更新頻度が落ちていて情報の鮮度が悪いです。

三流解説動画の再生リスト
https://www.youtube.com/user/ken3video/playlists

本当に三流なんです(笑):たまにスゴイですねなんて言われることもありますが、
真実は→ [三流君の真実は...] ←を初めに見てくださるとわかると思います。
(からくりは、成功例↑しか載せてなくて ヒドイ失敗例はお蔵入り迷宮入りが多かったりします)