Excel (VBA)

Excel VBAに関するフォーラムです。
  • 掲示板への投稿には会員登録(無料)が必要です。会員登録がまだの方はこちら
  • 掲示板ご利用上のお願い」に反するご記入はご遠慮ください。
  • Q&A掲示板の使い方はこちらをご覧ください
トピックに返信
質問

 
(Windows 7 Ultimate : Excel 2013)
Querytables.addでロト6のページを取り込めなくなりました。
投稿日時: 18/04/13 17:56:39
投稿者: お茶

お世話様です。
 
みずほ銀行のロト6当せん番号ページをエクセルに読み込むVBAを作って、
いままで毎回問題なく使用していました。
 
Querytables.addでエクセルに正常に取り込めていたのですが、
みずほ銀行側のページの変更で、httpがhttpsに変わったからなのか、
エクセルに取り込んだシートには、見出しだけで結果数字など反映されていませんでした。
 
今までのURLは、
 "URL;http://www.mizuhobank.co.jp/takarakuji/loto/loto6/index.html"
だったのですが、
 
変更後は、
  "URL;https://www.mizuhobank.co.jp/retail/takarakuji/loto/loto6/index.html"
に変わってしまいました。
 
ソースを見たのですが、肝心の結果数字が変数になっていて、
そもそもどこから持ってきているのかも分かりませんでした。
 
抽せん数字をエクセルに取り込む方法など無いのでしょうか?
 
VBAから脱線した質問が絡んでいるので申し訳ございませんが
お許しください。

回答
投稿日時: 18/04/13 20:08:49
投稿者: hatena
投稿者のウェブサイトに移動

スクリプトで動的に当選番号を生成するように変更になっているので、
Querytables.addでは取り込めなくなってます。
 
VBAでIEを操作して、当選番号が生成されるまで待機してから、取得するようにする必用があります。
 
下記の私の回答が参考になるでしょう。
 
Excel Q&Aサロン(VBA)
宝くじ当選データの取り込みが出来なくなった-
http://excelfactory.net/excelboard/excelvba/excel.cgi?mode=all&namber=185023&rev=0
 
上記は、ミニロトを当選番号の取り込みですが、URLを変更するだけで対応できます。
 

回答
投稿日時: 18/04/19 00:43:51
投稿者: hatena
投稿者のウェブサイトに移動

『お〜いお茶!』
いや、ちょっと言ってみたかっただけです。
 
ミニロト、ロト6、ロト7 の当選番号を取得してシートに出力する関数です。
標準モジュールを新規作成して、コピーしてご利用ください。
 

Option Explicit
Public Declare Sub Sleep Lib "kernel32" (ByVal ms As Long)

Public Enum loto
    miniloto = 1
    loto6 = 2
    loto7 = 3
End Enum

Private Const cURL = "https://www.mizuhobank.co.jp/retail/takarakuji/loto/$/index.html"

'ロト当せん番号取得関数
'引数 OutputCell:出力範囲の起点セル(省略可能)
'         省略した場合は、アクティブシートのA1セル
'   sYear:過去データの年を指定(省略可能)
'   sMonth:過去データの月を指定(省略可能)
'      sYear, sMonth を省略した場合は、最新のデータ
'      aloto:miniloto, loto6, loto7 のいずれかを指定(省略可能)
'         省略した場合は、miniloto
Sub Get_loto_result(Optional aloto As loto = 1, Optional OutputCell As Range, Optional sYear As String, Optional sMonth As String)
    
    Dim i As Long, r As Long, c As Long
    
    If OutputCell Is Nothing Then Set OutputCell = ThisWorkbook.ActiveSheet.Cells(1, 1)
    
    OutputCell.Parent.Cells.Clear
    
    Dim objIE As InternetExplorer    'IEオブジェクトを準備
    Set objIE = CreateObject("Internetexplorer.Application")    '新しいIEオブジェクトを作成してセット

    objIE.Visible = True    'IEを表示
    
    Dim sURL As String
    sURL = Replace(cURL, "$", Choose(aloto, "miniloto", "loto6", "loto7"))
    
    If sYear <> "" And sMonth <> "" Then sURL = sURL & "?year=" & sYear & "&month=" & sMonth
    objIE.navigate sURL    'IEでURLを開く

    Do While objIE.Busy = True Or objIE.readyState < READYSTATE_COMPLETE    '読み込み待ち
        DoEvents
    Loop

    Dim htmlDoc As HTMLDocument    'HTMLドキュメントオブジェクトを準備
    Set htmlDoc = objIE.document    'objIEで読み込まれているHTMLドキュメントをセット

    Dim colTbl As IHTMLElementCollection
    Set colTbl = htmlDoc.getElementsByTagName("table")    'HTMLドキュメント内のtable要素をコレクションとしてGet
    
    '当選番号一覧は動的に生成されるため、
    'テーブル数が4以上になるまで待つ(最大5秒間)
    For i = 1 To 50
        Sleep 100
        DoEvents
        If colTbl.Length >= 3 Then Exit For
    Next
    If colTbl.Length < 3 Then
        MsgBox "取得できませんでした。しばらく待って再トライしてください。"
        objIE.Quit
        Exit Sub
    End If

    For i = 0 To (colTbl.Length / 2) - 1
        Dim el As IHTMLElement, elC As IHTMLElement
        For Each el In colTbl(i).getElementsByTagName("tr") 'table内のtr要素(行)を順に取得
            c = 0
            For Each elC In el.all 'tr内の要素を順に取得
                If elC.tagName Like "T[DH]" Then 'th または td 要素なら
                    If elC.colSpan > 1 Then OutputCell.Offset(r, c).Resize(, elC.colSpan).Merge 'colSpan属性が2以上なら、それにあわせてセル結合
                    OutputCell.Offset(r, c).Value = elC.innerText
                    c = c + elC.colSpan
                End If
            Next elC
            r = r + 1
        Next el
        r = r + 1
    Next
    objIE.Quit 'IEを閉じる
    MsgBox "取得完了"
End Sub

Public Sub getLoto6()
    '最新のロト6の当選番号を取得
    Get_loto_result loto6    
End Sub

Public Sub getLoto7()
    '最新のロト7の当選番号を取得
    Get_loto_result loto7   
End Sub

Public Sub getMiniLoto()
    '最新のミニロトの当選番号を取得
    Get_loto_result miniloto    
End Sub

トピックに返信