excel VBA webからデータを取り込むマクロについて

Public Function HtmlR(URL As String) As HTMLDocument
Dim buf As Object, objHTML As Object
Dim http As XMLHTTP60
Set http = CreateObject("MSXML2.XMLHTTP")
Set buf = New HTMLDocument


http.Open "GET", URL, False
http.send

Do While http.readyState <> 4
DoEvents
Loop

buf.write http.responseText

If InStr(Split(Split(http.responseText, "charset=")(1), ">")(0), "8") = 0 Then
Set buf = Nothing
With CreateObject("ADODB.Stream")
.Charset = "_autodetect"
.Type = 1
.Open
.write http.responseBody
.Position = 0
.Type = 2
buf.write .ReadText
.Close
End With
End If

Set objHTML = buf
Set HtmlR = objHTML

Set buf = Nothing
Set http = Nothing
Set objHTML = Nothing

End Function

Sub 計算用データ入手()
Application.DisplayAlerts = False
Application.ScreenUpdating = False

Dim sy As String
Dim sm As String
Dim sd As String
Dim ey As String
Dim em As String
Dim ed As String
Dim code As String
Dim page As Long
Dim URL As String
Dim Pc As Integer
Dim Tobj As HTMLTable
Dim URLL As String
Dim Htdoc1 As New HTMLDocument
Dim text As TextStream
Dim fso As New FileSystemObject

sy = 2000
sm = 1
sd = 1
ey = 2016
em = 12
ed = 29

Workbooks.Add

Set text = fso.OpenTextFile("C:\Users\SK\Desktop\計算用データ入手東証二部.txt")

Do Until text.AtEndOfLine
code = text.ReadLine

Workbooks.Add

URLL = "http://stocks.finance.yahoo.co.jp/stocks/chart/? … & code & ".T&ct=z&t=1y&q=c&l=off&z=m&p=m65,m130,s&a=v"
Set Htdoc1 = HtmlR(URLL)
range("A1") = Split(Htdoc1.Title, "：")(0)

range("A2").Select

For page = 1 To 1000
URL = "http://info.finance.yahoo.co.jp/history/?code=" & code & ".T&sy=" & sy & "&sm=" & sm & "&sd=" & sd & "&ey=" & ey & "&em=" & em & "&ed=" & ed & "&tm=d&p=" & page
Dim Htdoc As New HTMLDocument
Set Htdoc = HtmlR(URL)
If Htdoc.getElementsByTagName("table")(1).Rows.Length = 1 Then Exit For

With New MSForms.DataObject
.SetText Htdoc.getElementsByTagName("table")(1).outerHTML
.PutInClipboard
End With

ActiveSheet.PasteSpecial Format:="Unicode テキスト", link:=False, DisplayAsIcon:=False, NoHTMLFormatting:=True
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Select

Next page

Dim fn As String
fn = range("A1")
ActiveSheet.Name = fn
range("A1").Select
ActiveWorkbook.SaveAs filename:="C:\Users\SK\Documents\マクロ用データ入れ\東証二部(20000101-20161229)\" & fn & ".xlsx" _
, FileFormat:=xlOpenXMLWorkbook, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
ActiveWorkbook.Close

Loop

Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub




上記のプログラムを作成しました。
計算用データ入手.txtには証券コード(4桁の数字)が並んでおり、その数字ごとに結果が保存されるようにしています。
一応上記のプログラムで動くのですが、200個ほど並んでいるコードのうち、5個ほどが終わった時点で、進まなくなってしまいます。
excel上でエラー表示がされることはなく、動いていなさそうだなと思って、エスケープを押してキャンセルしようとすると、フリーズしてしまいます。
5個の計算が終わった時点でフリーズして、また一から計算を動かすという面倒なことになっているので、改善案をご教示いただければと思います。
Application 移動用計算用データはデータのセルを移動しているだけなので、無視していただいて構いません。
また、PC本体の動作・ネットワーク環境には問題ないと思われます。
よろしくお願いいたします。

質問者からの補足コメント

• Win32APIであったり、知識不足で理解できない部分があるのですが、
  とりあえず動かすことができず、困っています。
  NextFile:
  の部分でエラーが出てしまうのですが、どのように対処すればよいのでしょうか。
  ご教示お願いします。

  No.2の回答に寄せられた補足コメントです。 補足日時：2017/01/13 22:41

No.3 ベストアンサー 回答者： WindFaller 回答日時： 2017/01/14 23:53

エラーそのものよりも、#1のコードは、フルコードではありません。

お分かりにはなっているとは思いますが、リストはインポートするのではなく、すでにシートに書かれています。

Set RngData = ThisWorkbook.Worksheets("Sheet4").Range("A1:A20")　'20ファイルで試しました

Sheet4
A列
9399
6944
8886
2163
3842
　.
　.
になっています。

Win32APIは、特に重要ではありませんから、それは無視しても構わないと思います。比較的負荷の多いコードですから、どこかに余裕を置くために、Sleep を入れたほうが無難だというだけの話です。VBAの内部の関数よりも、外部関数などを使ったほうが負担が少ないからです。

こちらは、Excel 2013, Windows10 で作っています。Excel 2007 以降なら大丈夫だとは思いますが、それ以外のものは、今のところ想定外です。

また参照設定は、
Private objHTTP As WinHttp.WinHttpRequest 'Microsoft WinHTTP Service, version 5.1
Private oHtml As HTMLDocument　''Microsoft HTML Object Library
（実際は、これに正規表現のVBScript をCreateObjectで呼び出ししています）
--------
結果
Microsoft HTML Object Library
Microsoft WinHTTP Services, version 5.1

>NextFile:
>の部分でエラーが出てしまうのですが、どのように対処すればよいのでしょうか。
以下のように直してみてください。ただ、どのようなエラーが出ているかにもよります。
ループ上でエラーが発生すると、イミディエイトウィンドウの中にファイル名が残ります。

'//
NextFile:
　　End If
　Next code
　MsgBox "終了しましたが、一度ファイルを確認してみてください。", vbInformation
　Exit Sub
ErrHandler:
　Debug.Print Application.StatusBar
　Application.StatusBar = False
　Resume NextFile
End Sub

もちろん、エラー処理の仕方を変える方法もありますが、致命的な欠陥が発生しない限りは、当面は考えておりません。ただ、元の会社の番号からのエラーが出ない限りは、そのような場所ではエラーはでないはずです。

いずれにしても、私自身が、ご質問者さんのコードを読みきれないというか、どうしても、クリアできない所があると同じように、いくら、こちらのコードをベタで試したところで、細かな設定が食い違う場合があろうかと思います。

そこで、サンプルファイルを用意しましたので、それを使ってみてください。リストはご自分用に書き換えてください。公開期間は、3日（1/14 23:00+3days)の猶予しかありませんので、もし、ダウンロードしそこねましたら、また掲示板に書いてください。今回は、自己解凍ファイルですが、プロパティでブロック解除は必要になりますから、ご注意ください。

パスワードは、このログの9から始まる7桁の数字です。
もし、自己解凍がお嫌いでしたら、圧縮解凍ユーティリティで開けるはずです。
ファイルはZIP圧縮です。

http://bit.ly/2jPXSNF

この回答へのお礼

作っていただいたプログラムの使い方が分からず断念しました。
でも、VBSとVBAを組み合わせたら少し時間がかかりますが、問題なく動きそうです。
VBSで番号を指定したら、その番号のデータをexcelに取り込んで、excelの動作を一回きって、
もう一度VBSで番号を指定して
みたいな感じです。
yahoo financeに連続アクセスすることがアクセス制限につながるらしくて、一回excelの動作を完全に切ることで、アクセス制限を避けることができたのかな？という感じです。力技ですが（笑）
アドバイス大変勉強になりました。
またご教示お願いいたします。

お礼日時：2017/01/16 22:51

No.5 回答者： VT250F 回答日時： 2017/01/16 22:41

試しに実行してみましたが、データベースやらＸＭＬやらを参照設定しなければならず、

時間がないので断念しました。
株価を検索させて、結果をエクセルに出すとは高度な事をされていますね。
ここはメイン（最初の起動）サブルーチン『計算用データ入手』ですか。
ここを表示させてファンクションキー８番を押してステップ実行させてみてはいかがでしょう。
http.Open "GET", URL　で５回目にフリーズと言う事は、
たとえ Nothingをセットしていても、オープンのしすぎでメモリ不足になっているのかもしれません。
メモリ容量の減り方を見つつ、OpenしたものはCloseを考えてメモリを開放するとか、
どのステップに問題があるか、調べるとよいかもしれませんね。
色々と原因を探す価値はあると思います。
健闘を祈ります。

No.4 回答者： WindFaller 回答日時： 2017/01/15 20:50

#3の内容の変更をお知らせします。

圧縮自動解凍ファイルの'exe' ファイルは、セキュリティの警告が出過ぎましたので、こちらに変更しました。（1/15 20:45 + 72 hour)
http://bit.ly/2iWdsDu

パスワードは前回と同じです。

ダウンロード後は、プロパティからブロック解除をしてください。

No.2 回答者： WindFaller 回答日時： 2017/01/10 06:53

結局、他人のコードを直すよりも、私自身で新たなコードを書いたほうが早いです。

トライしたのは、20ファイルのみですが、100や200は、特に問題なさそうに思います。

フリーズの原因は、どうやら、UserFormのDataObject です。これは、使えないようです。その場合は、Tableではなく、他の方法を取るのですが、今回は、Tableのままにしました。切り分けには、Basp21というツールの正規表現を使うと便利なのですが、それはやめました。TableをClipBoardから、シートに貼り付けるのは、便利なのですが、ClipBoard は、やはり、Win32APIで行ったほうがうまくいくのではないかと思います。ただし、開け閉めが面倒です。今回のデータの切り分けは、臨時の処置です。

ご質問者さんのコードは、全体的にみて、そのまま、ネットにアクセスするには、それぞれのコードの負荷が強すぎるように思うのです。理屈では可能でも、ExcelのVBAの実行メモリというのは、想像以上に小さいので無理があるようです。また、タイトルだけ取って、もう一度アクセスするというのも、無駄があるように思いました。

もう一つの問題点は、
>Set text = fso.OpenTextFile("C:\Users\SK\Desktop\計算用データ入手東証二部.txt")
>Do Until text.AtEndOfLine
>code = text.ReadLine

こういう所ですね。これを、Excelのブックのシートに置くことを考えました。
本来は、シートに一覧で出してしまい、その後を呼び出しをするとか、したほうが負荷が少ないと思います。

なお、私のコードでは、画面の左下のステータスバー部分に処理中のファイル名が出るようになっています。

最後に、今回のコードは出来る限り、参照設定をして負荷を減らそうと考えました。私の思惑の中だけで進めたコードからですから、まだ、修正が必要かもしれません。

No.1 回答者： WindFaller 回答日時： 2017/01/10 06:40

解説は、次の書き込みでします。

'//
Private objHTTP As WinHttp.WinHttpRequest 'Microsoft WinHTTP Service, version 5.1
Private oHtml As HTMLDocument　''Microsoft HTML Object Library
Private sh1 As Worksheet
Private Declare Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As Long)

Sub Main()
　Dim URL As String
　Dim code As Variant
　Dim RngData As Range
　Dim c As Variant
　Dim sy, sm, sd, ey, em, ed, page
　On Error GoTo ErrHandler
　Set sh1 = ThisWorkbook.Worksheets("Sheet1")
　
　'コードデータ** (テキストインポートをやめて、データをシートに置いた）
　Set RngData = ThisWorkbook.Worksheets("Sheet4").Range("A1:A20")　'20ファイルで試しました
　For Each c In RngData
　 If Application.CountIf(RngData, c) > 1 Then
　　　MsgBox c.Value & " :のコードが重複しています", vbExclamation
　　　Exit Sub
　 End If
　Next
　
　sy = 2000:　sm = 1:　sd = 1:　ey = 2016:　em = 12:　ed = 29: page = ""
　For Each code In RngData.Cells
　　Application.ScreenUpdating = False
　　sh1.Range("A1").CurrentRegion.ClearContents
　　If IsNumeric(code) Then
　　　
　　　URL = "http://info.finance.yahoo.co.jp/history/?code=" _
　　　& code & ".T&sy=" & sy & "&sm=" & sm & "&sd=" & sd & "&ey=" & ey & "&em=" & em & "&ed=" & ed & "&tm=d&p=" & page
　　　Call AccessDOM(URL)
　　　DoEvents
　　　Sleep 500
　　　Application.ScreenUpdating = True
NextFile:
　　End If
　Next code
　MsgBox "終了しましたが、一度ファイルを確認してみてください。", vbInformation
　Exit Sub
ErrHandler:
　Debug.Print Application.StatusBar
　Application.StatusBar = False
　GoTo NextFile
End Sub

Sub AccessDOM(strURL As String)
　　Dim httpLog As String
　　Dim ar As Variant
　　Dim n As Variant
　Set objHTTP = New WinHttp.WinHttpRequest '("WinHttp.WinHttpRequest.5.1")
　　
　　objHTTP.Open "GET", strURL, False
　　objHTTP.send
　
　　If objHTTP.Status = 200 Then
　　　　httpLog = objHTTP.responseText
　　　 Call RelateLog(httpLog)
　　Else
　　　　MsgBox "アクセスに失敗しました。"
　　End If
End Sub
Sub RelateLog(httpLog As Variant)
　Dim buftxt As String
　Dim tb1 As Object
　Dim wb As Workbook
　Dim fn As String
　Dim rng As Range
　Dim objData As DataObject
　Set oHtml = New HTMLDocument
　oHtml.body.innerHTML = httpLog
　With oHtml
　　Dim oSymb
　　Set oSymb = .getElementsByClassName("symbol")
　　If oSymb.Length > 0 Then
　　　sh1.Range("A1").Value = oSymb(0).innerText
　　　Application.StatusBar = oSymb(0).innerText
　　End If
　　Set tb1 = .getElementsByTagName("table")
　　If tb1.Length > 0 Then
　　　buftxt = tb1(1).outerHTML
　　　Call SplitData(buftxt)
　　Else
　　　GoTo EndLine
　　End If
'　　ここで、DataObjectを使う予定でした。
　　　fn = sh1.Range("A1").Value
　　　Set rng = sh1.Range("A1").CurrentRegion
　　End With
　　　　 Workbooks.Add
　　　　 rng.Copy ActiveSheet.Range("A1")
　　　　 ActiveSheet.Range("A1").CurrentRegion.Columns.AutoFit
　　　　 Call SaveFiles(fn)
　End With
EndLine:
　Application.StatusBar = False
End Sub
Sub SaveFiles(fn As String)
　Dim n As Variant
　Const myPATH As String = "C:\Users\SK\Documents\マクロ用データ入れ\東証二部(20000101-20161229)\"
　ActiveSheet.Name = fn
　fn = Replace(fn, "(株)", "", 1, 1, vbTextCompare)
　Range("A1").Select
　Application.DisplayAlerts = False
　　ActiveWorkbook.SaveAs Filename:=myPATH & fn, FileFormat:=xlOpenXMLWorkbook
　　Application.DisplayAlerts = True
　ActiveWorkbook.Close False
End Sub
Sub SplitData(arg1 As String)
'テーブルの切り分け
　Dim re As Object
　Set re = CreateObject("VBScript.RegExp")
　With re
　　.Global = True: .IgnoreCase = False: .MultiLine = True
　End With
　Dim Ar0
　Dim Ar1
　Dim Ar2
　Dim k As Long, i As Long, j As Long
　Dim a, Ms As Object, m As Object
　Ar0 = Split(arg1, "TR")
　Ar1 = Split(Ar0(1), "TH")
　k = 3: j = 1
　re.Pattern = "\>([^\<].+)<"
　For Each a In Ar1
　　Set Ms = re.Execute(a)
　　If Ms.Count > 0 Then
　　　Cells(2, j).Value = Ms(0).SubMatches(0)
　　　j = j + 1
　　End If
　　If InStr(1, a, "*", vbBinaryCompare) > 0 Then Exit For
　Next
　
　re.Pattern = "\>([^\<].+)\</."
　j = 0
　For i = 3 To UBound(Ar0) Step 2
　　a = Ar0(i)
　　Set Ms = re.Execute(a)
　　If Ms.Count > 0 Then
　　　j = 1
　　　For Each m In Ms
　　　　Cells(k, j).Value = m.SubMatches(0)
　　　　j = j + 1
　　　Next m
　　　k = k + 1
　　End If
　Next i

End Sub