vbaでweb上から時系列データを取得したいのですが・・・

初心者です。
これまで下記サイトより、webクエリーを使ってエクセルに時系列データを取込んでいたのですがサイトの構成が変わりできなくなりました。
ＩＥを制御して取込む方法を試してみましたが、うまくできませんでした。マクロコードを記述して教えていただければありがたいです。（いろんな方法を教えていただいても初心者なので私の力ではできないと思います。）
よろしくお願いします。

http://k-db.com/stocks/8306-T/4h

No.1 ベストアンサー 回答者： WindFaller 回答日時： 2016/04/20 13:21

こんにちは。

>時系列データを取込んでいたのですが
ということは、

日足　前場後場　1時間足　30分足　15分足　5分足
この6つということですか？

本来は、ご質問にあるように、Webクエリに近いスタイルで作るべきでしたが、今は、どこのサイトでも、スクレイピングが嫌われるよううなので、そのサイトの、CSVダウンロードのポートを利用してみました。

このマクロは、6種類をダウンロードしてくるのと、それを「新規のブック」にインポートします。今回は、個人的に新しい試みです。

>ＩＥを制御して取込む方法を試してみましたが、
まずかったら、そちらのスタイルに戻すつもりでいます。かなり、鈍速になるはずです。
他にも、DOMでインポートする方法があります。以下のマクロは、最終的な書式処理が抜けております。その点はお詫びいたします。

なお、これは、私の個人的・継続的にVBAマクロの練習をしているので、教えているのではなく、ご質問を利用させていただいているのです。

参考サイト：
http://www.ka-net.org/blog/?p=4855

'//'標準モジュールに貼り付けてください。
Private Declare Function DeleteUrlCacheEntry Lib "wininet" Alias "DeleteUrlCacheEntryW" (ByVal lpszUrlName As Long) As Long
Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileW" (ByVal pCaller As Long, ByVal szURL As Long, ByVal szFileName As Long, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
Private Filename As String
Private NewBook As Workbook
Private ShCount As Long
Private Er As Long
Sub DownLoadFiles()
　　Dim Ret As Long
　　Dim mPath As String: mPath = ThisWorkbook.Path & "\"
　　Dim Filename As String
　　Dim buf As Variant
　　Dim BaseUrl As String
　　Dim Url As String
　　Dim Urls As Variant, sAdd As Variant
　　Dim SaveFilePath As String
　　
　　'*****************
　　'目的のURL を入れてください。
　　BaseUrl = "http://k-db.com/stocks/1458-T/"
　　Urls = Array("", "4h", "1h", "30m", "15m", "5m") 'ダウンロード項目
　　'*****************
　　
　　If NewBook Is Nothing Then
　　　　Set NewBook = Workbooks.Add 'ブックを作る
　　End If
　　
　　buf = Split(BaseUrl, "/")
　　If InStr(1, BaseUrl, "k-db.com/stocks", 1) = 0 Then 'Urlをチェック
　　　　MsgBox "URLは、【株式データサイト】に限ります。", vbExclamation
　　　　Exit Sub
　　End If
　　buf = buf(3) & "_" & buf(4) 'ダウンロード名を生成
　　
　　For Each sAdd In Urls
　　　　If Len(sAdd) > 0 Then
　　　　　　SaveFilePath = mPath & buf & "_" & sAdd & ".csv"
　　　　Else
　　　　　　SaveFilePath = mPath & buf & sAdd & ".csv"
　　　　End If
　　　　
　　　　Url = BaseUrl & sAdd & "?download=csv"
　　　　''MsgBox Url 'URLチェック用
　　　　Ret = DownloadFile(Url, SaveFilePath)
　　　　If Ret <> 0 Then
　　　　　　MsgBox "取得に失敗しました。", vbExclamation
　　　　Else
　　　　　　If Dir(SaveFilePath) <> "" Then
　　　　　　　　ImportFiles SaveFilePath
　　　　　　Else
　　　　　　　　MsgBox "ダウンロードに失敗しました", vbCritical
　　　　　　　　Er = Er + 1
　　　　　　End If
　　　　End If
　　Next sAdd
　　If Err = 0 Then
　　　　MsgBox "正常に終了しました。", vbInformation
　　End If
End Sub

Private Function DownloadFile(ByVal Url As String, ByVal SaveFilePath As String)
Dim Ret As Long
　　DeleteUrlCacheEntry StrPtr(Url) 'キャッシュクリア
　　Ret = URLDownloadToFile(0, StrPtr(Url), StrPtr(SaveFilePath), 0, 0)
　　DownloadFile = Ret
End Function

Sub ImportFiles(ByVal FilePath As String)
　　　　Dim Fname As String
　　　　Dim FNo As Integer
　　　　Dim TextLine As String
　　　　Dim i As Long
　　　　Dim Ar As Variant
　　　　ShCount = ShCount + 1
　　　　With NewBook
　　　　　　If ShCount > .Worksheets.Count Then
　　　　　　.Worksheets.Add After:=.Sheets(.Sheets.Count)
　　　　　　Else
　　　　　　 .Worksheets(ShCount).Activate
　　　　　　End If
　　　　End With
　　　　ActiveSheet.Name = _
　　　　Replace(Mid$(FilePath, InStrRev(FilePath, "\") + 1), ".csv", "", , , vbTextCompare)
　　　　i = 1
　　　　Fname = FilePath
　　　　FNo = FreeFile()
　　　　Open Fname For Input As #FNo
　　　　Do While Not EOF(FNo)
　　　　　　Line Input #FNo, TextLine
　　　　　　Ar = Split(TextLine, ",")
　　　　　　Cells(i, 1).Resize(, UBound(Ar) + 1).Value = Ar
　　　　　　i = i + 1
　　　　Loop
　　　　Close #FNo
End Sub

この回答へのお礼

WindFaller様
早速にありがとうございました。いろんな方法を教えていただき、解決しました。
＞そのサイトの、CSVダウンロードのポートを利用してみました。
この方法も考えたのですが全く方法がわからず、途方に暮れていました。
感謝　感謝です。

お礼日時：2016/04/21 21:17