vbaでweb上から株価（5分足）を時系列でマクロでエクセルexcelで取得

初心者です。
下記サイトより、株価の５分足がcsvでダウンロードできるのですが、それをエクセルでマクロで取込めるマクロコードを記述して教えていただければありがたいです。
銘柄を１つ１つダウンロードするのが大変なので、エクセルのシートに４ケタの株コードをA列に縦に羅列して、一度にシート・タブにダウンロードしたいと思ってます。

http://k-db.com/stocks/8306-T/5m

なお、以下の過去の質問を自分でどうにか改造してみたのですが、初心者で断念した程度の初心者です。
https://oshiete.goo.ne.jp/qa/9249151.html

No.1 回答者： WindFaller 回答日時： 2017/10/06 09:56

こんにちは。

前のものを加工しました。
ちょっと気になるのは、直接のダウンロードが上手くいかないようで、一旦サイトにアクセスすることにしました。それと、一応、ブラウザはIEです。
ブラウザは、当初は'Visible がTrue になっていますが、見えない(=False)ようにしてもしても可。全体的には、釈然としていない部分がありますので、もう一度、解体して組み直した方がよいかもしれません。

今、IEは微妙に変化し、また、使い勝手が落ちてきていますので、突然使えなくなることもあります。

シートには、A列は4桁番号だけを置いてください。
最初、数字だけで、きちんとエラーなくアクセスしていれば、名前が出てきます。
失敗した時は、C列に×がつけられてしまいます。

添付画像参照
　[フォームボタン ]　データは2行目から
　[クリアボタン]の内容は省略します。


'//
Option Explicit

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 SaveFilePath As String
Private NewBook As Workbook
Private ShCount As Long
Private tbName As String
Private objIE As SHDocVw.InternetExplorer 'Microsoft Internet Control 要参照設定

Sub Main()
Dim shCont As Long
Dim c As Range
Set objIE = New SHDocVw.InternetExplorer
ShCount = 1
On Error GoTo ErrHandler
With Worksheets("Sheet1")
For Each c In .Range("A2", .Cells(Rows.Count, 1).End(xlUp))
　If c.Value Like "####" Then
　　If DownLoadFiles(c.Value) Then
　　　DoEvents
　　　c.Offset(, 1).Value = tbName
　　　Call ImportFiles(SaveFilePath)
　　Else
　　　c.Offset(, 2).Value = "×"
　　End If
　End If
Next c
End With
objIE.Quit
Set objIE = Nothing
Worksheets("Sheet1").Select
Exit Sub
ErrHandler:
MsgBox Err.Number & ": " & Err.Description
End Sub
Function DownLoadFiles(ByVal Nos As String)
　　Dim Ret As Long
　　Dim mPath As String: mPath = ThisWorkbook.Path & "\"
　　Dim buf As Variant
　　Dim BaseUrl As String
　　Dim companyNo As String
　　Dim myUrl As String
　　Dim strPostchar As String
　　Dim tbCap As Object
　　Dim dLink As Variant, dl_Cn As Variant
　　
　　BaseUrl = "http://k-db.com/stocks/"
　　
　　If Len(Nos) < 4 Then
　　　companyNo = Format$(Val(Nos), "0000")
　　Else
　　　companyNo = Nos
　　End If
　　SaveFilePath = ThisWorkbook.Path & "\" & companyNo & ".csv"
　　
　　 objIE.Navigate2 BaseUrl & companyNo
　　 objIE.Visible = True ''Visible がTrue になっています。False でも可
　　 AppActivate Application.Caption
　　 Do While objIE.Busy Or objIE.ReadyState <> 4: DoEvents: Loop
　　
　　With objIE
　　　Set tbCap = .Document.getElementByID("tablecaption")
　　　
　　　tbName = tbCap.innerText
　　　tbName = Mid(tbName, InStr(1, tbName, "]") + 1)
　　　
　　　Set dLink = .Document.getElementByID("downloadlink")
　　　Set dl_Cn = dLink.ChildNodes
　　　myUrl = dl_Cn(0).href
　　End With
　
　　　　Ret = DownloadFile(myUrl, SaveFilePath)
　　　　If Ret <> 0 Then
　　　　　DownLoadFiles = False
　　　　Else
　　　　　　If Dir(SaveFilePath) <> "" Then
　　　　　　　 DownLoadFiles = True
　　　　　　Else
　　　　　　　 DownLoadFiles = False
　　　　　　End If
　　　　End If
　　
End Function

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 ThisWorkbook
　　　　　　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 = 2
　　　　Fname = FilePath
　　　　ActiveSheet.Cells(1, 1).Resize(, 3).Merge
　　　　ActiveSheet.Cells(1, 1).Value = tbName
　　　　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
　　　　ActiveSheet.Columns("A:G").AutoFit
End Sub

No.2 回答者： fujillin 回答日時： 2017/10/06 10:35

こんにちは

とりあえず、ご指定のcsvをシートに取り込むだけのものですが・・・
こんな感じではいかがでしょうか？

Sub Sample()
Dim wb As Workbook, r As Range
ThisWorkbook.FollowHyperlink Address:="http://k-db.com/stocks/8306-T/5m?download=csv"
Set wb = ActiveWorkbook
With wb.ActiveSheet
　Set r = .Range("A1:A" & .Cells(Rows.Count, 1).End(xlUp).Row)
　r.TextToColumns Destination:=r.Cells(1, 1), DataType:=xlDelimited
　r.Resize(r.Rows.Count, 8).Copy Destination:=ThisWorkbook.ActiveSheet.Cells(1, 1)
End With
wb.Close SaveChanges:=False
End Sub

No.3 ベストアンサー 回答者： WindFaller 回答日時： 2017/10/06 16:36

#1の回答者です。

思ったとおり、IEによるアクセスは不要でした。

Option Explicit
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 SaveFilePath As String
Private ShCount As Long
Private tbName As String

Sub Main2()
Dim shCont As Long
Dim c As Range
ShCount = Worksheets.Count
On Error GoTo ErrHandler
With Worksheets("Sheet1")
For Each c In .Range("A2", .Cells(Rows.Count, 1).End(xlUp))
If c.Value Like "####" Then
If getDownLoadFiles2(c.Value) Then
c.Offset(, 1).Value = tbName
Else
c.Offset(, 2).Value = "×"
End If
End If
Next c
End With
Worksheets("Sheet1").Select
Exit Sub
ErrHandler:
MsgBox Err.Number & ": " & Err.Description
End Sub
Private Function getDownLoadFiles2(ByVal CompanyNo As String)
Dim objHTTP As WinHttp.WinHttpRequest '要参照設定
Set objHTTP = New WinHttp.WinHttpRequest '.WinHttpRequest '("WinHttp.WinHttpRequest.5.1")
Dim Ret As Long
Dim mPath As String: mPath = ThisWorkbook.Path & "\"
Dim BaseUrl As String
Dim myUrl As String
Dim strPostchar As String
Dim tbCap As Object
Dim dLink As Variant, dl_Cn As Variant
Dim URL As String
Dim httpLog As String
BaseUrl = "http://k-db.com/stocks/"
If Len(CompanyNo) < 4 Then
CompanyNo = Format$(Val(CompanyNo), "0000")
End If
SaveFilePath = ThisWorkbook.Path & "\" & CompanyNo & ".csv"
URL = BaseUrl & CompanyNo
objHTTP.Open "GET", URL, False
objHTTP.setRequestHeader "Pragma", "no-cache"
' objHTTP.setRequestHeader "Cache-Control", "no-cache"
' objHTTP.setRequestHeader "Connection", "keep-alive"
objHTTP.Send
If objHTTP.Status = 200 Then
httpLog = objHTTP.ResponseText
Call GetDownLoadFileName(httpLog)
getDownLoadFiles2 = True
Else
getDownLoadFiles2 = False
End If
Exit Function
ErrHandler:
If Err() > 0 Then
getDownLoadFiles2 = False
Debug.Print Err.Number '特別なエラー
End If
End Function

Function GetDownLoadFileName(httpLog As String)
Dim oHtml As HTMLDocument '要参照設定
Dim tbCap As Object
Dim dLink As Object
Dim dl_Cn As Variant
Dim myUrl As String
Dim Ret As Long
Set oHtml = New HTMLDocument
oHtml.body.innerHTML = httpLog
With oHtml
Set tbCap = .getElementByID("tablecaption")
tbName = tbCap.innerText
tbName = Mid(tbName, InStr(1, tbName, "]") + 1)
Set dLink = .getElementByID("downloadlink")
Set dl_Cn = dLink.ChildNodes
myUrl = dl_Cn(0).href
End With
myUrl = Replace(myUrl, "about:/", "", , , vbTextCompare)
myUrl = "http://k-db.com/" & myUrl
GetDownLoadFileName = DownloadFile(myUrl, SaveFilePath)
Call ImportFiles(SaveFilePath)
End Function

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 ThisWorkbook
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 = 2
Fname = FilePath
ActiveSheet.Cells(1, 1).Resize(, 3).Merge
ActiveSheet.Cells(1, 1).Value = tbName
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
ActiveSheet.Columns("A:G").AutoFit
End Sub
'//
参照設定

この回答へのお礼

豊富なエラー処理も含んだ非常にリッチなコードでした。　すごい！

お礼日時：2017/10/06 23:08