No.1
- 回答日時:
>1999/1/1~2012/1/1
これは最新日までのデータを累積していきたいって事ですよね。
追加で取り込む頻度は毎日?毎週?
それによってコードの組み方も随分と変わってきます。
特にIE7の場合、table.yahoo.co.jpではWebクエリ連続実行が使えない場合がありますから
難易度も上がると思いますよ。
とりあえず、昔 /qa4201932.html で書いた事があるのでザッと修正したものを提示しておきます。
1999/1/1~最新日まで取り込みます。
シートを追加してコードをシート名にしますので既存シート名とダブりが無いようにしてください。
内容を理解して応用すれば、ある一定の期間からの追加仕様に変更できるかと思います。
(私は、今回そこまでやるつもりはないですが)
Option Explicit
Sub try()
Const FLD As String _
= "日付 始値 高値 安値 終値 出来高 調整後終値*" '列項目名
Const CX As Long = 7 '配列の列数(項目数)
'Const YY As Long = 10 '期間年数
Const PTN As String = ">([^<>\n]+)<" 'データ抜き出しパターン
Dim dCHK As Date '開始期間Date
Dim dTMP As Date '検索開始Date
Dim xh As Object 'MSXML2.ServerXMLHTTP
Dim re As Object 'VBScript.RegExp
Dim mc As Object 'RegExp.Match
Dim url As String 'URLアドレス
Dim chk As String 'テーブル判断項目htmlTEXT
Dim ret As String 'XMLHTTP.responsetext
Dim s(7) As String 'URL構成文字列
Dim flg As Boolean 'LoopOut判定FLG
Dim rng As Range '銘柄コード範囲
Dim r As Range 'RangeLoop用
Dim dX As Long '期間日数
Dim n As Long 'chk文字存在判定
Dim x As Long 'HTML項目Loop用
Dim cnt As Long 'データCOUNT
Dim i As Long
Dim j As Long
Dim k As Long
Dim v, w 'データ格納用配列,列項目名分割用配列
'Dim t As Single
On Error Resume Next
Set xh = CreateObject("MSXML2.ServerXMLHTTP")
On Error GoTo 0
If xh Is Nothing Then Exit Sub
'銘柄コードを記入している範囲を取得
With Sheets("Sheet1")
Set rng = .Range("A1", .Cells(.Rows.Count, 1).End(xlUp))
End With
w = Split(FLD)
'#m/d/yyyy#で開始日を設定
dCHK = #1/1/1999# 'DateAdd("yyyy", -YY, Date)
'開始日より1ページ多目に
dTMP = DateAdd("d", -50, dCHK)
s(1) = "c=" & Year(dTMP) '開始年
s(2) = "a=" & Month(dTMP) '開始月
s(3) = "b=" & Day(dTMP) '開始日
s(4) = "f=" & Year(Date) '現在年
s(5) = "d=" & Month(Date) '現在月
s(6) = "e=" & Day(Date) '現在日
s(7) = "g=d&q=t&y="
dX = CLng(Date - dCHK) + 1
'期間日数から配列の大きさを設定
ReDim v(0 To dX, 1 To CX)
'テーブル判断項目htmlTEXT
chk = "<small>" & w(CX - 1) & "</small></th>"
For i = 1 To CX
v(0, i) = w(i - 1)
Next
Set re = CreateObject("VBScript.RegExp")
re.Pattern = PTN
re.Global = True
't = Timer
'コード範囲をLoop
For Each r In rng
s(0) = "http://table.yahoo.co.jp/t?s=" & r.Value
url = Join(s, "&")
cnt = 1
For i = 0 To dX Step 50
xh.Open "GET", url & i, False
xh.Send
If (xh.Status >= 200) And (xh.Status < 300) Then
ret = xh.responsetext
n = InStr(ret, chk)
If n = 0 Then Exit For
ret = Mid$(ret, n + Len(chk))
Set mc = re.Execute(ret)
x = 0
For j = 1 + i To 50 + i
cnt = j
For k = 1 To CX
v(j, k) = mc(x).submatches(0)
'データ終了判定
If k = 1 Then
flg = IsDate(v(j, 1))
If flg Then
flg = (CDate(v(j, 1)) >= dCHK)
End If
If Not flg Then
j = i + 50
i = dX
Exit For
End If
End If
x = x + 1
Next
Next
End If
Next
'Debug.Print cnt
'シート追加し書き出し。
With Sheets.Add
.Range("A1").Resize(cnt, CX).Value = v
On Error Resume Next
.Name = r.Value
On Error GoTo 0
End With
'Debug.Print Timer - t
't = Timer
Next
Set rng = Nothing
Set mc = Nothing
Set re = Nothing
Set xh = Nothing
End Sub
一応、[winXPsp3/xl2003sp3][vistasp1/xl2007sp1]の環境で動作確認してますが、
上手くいかなかったらごめんなさい。
No.2ベストアンサー
- 回答日時:
>(私は、今回そこまでやるつもりはないですが)
...と書いておきながらやるワタシって...orz
Option Explicit
Sub test()
Dim fromDate As Date '取得開始日
Dim toDate As Date '取得終了日
Dim n As Long
Dim d, cds()
'Dim t As Single
't = Timer
'toDateに取得終了日をセット可能
toDate = Date '#8/31/2009#
With Sheets("Sheet1")
'B1セルから前回取得終了日をセット。最初は未入力で可
d = .Range("B1").Value
If IsDate(d) Then
If d >= toDate Then Exit Sub
fromDate = CDate(d + 1)
End If
'B1未入力だったら1999.1.1
If fromDate < #1/1/1999# Then
fromDate = #1/1/1999#
End If
'銘柄コードを配列で取得
n = .Cells(.Rows.Count, 1).End(xlUp).Row
If n = 1 Then
ReDim cds(0)
cds(0) = .Range("A1").Value
Else
cds() = .Range("A1").Resize(n).Value
End If
'引数:銘柄配列, 開始日, 終了日
Call getXML(cds(), fromDate, toDate)
'B1セルに今回取得終了日
.Range("B1").Value = toDate
End With
'Debug.Print Timer - t
End Sub
'---------------------------------------------------------------------
Sub getXML(ByRef cds() As Variant, _
ByVal dCHK As Date, _
ByVal dDate As Date)
Const FLD = "日付 始値 高値 安値 終値 出来高 調整後終値*" '列項目名
Const CX As Long = 7 '配列の列数(項目数)
Const PTN = ">([^<>\n]+)<" 'データ抜き出しパターン
Const CHK = "<small>調整後終値*</small></th>" 'テーブル判断項目htmlTEXT
Dim dTMP As Date '検索開始Date
Dim xh As Object 'MSXML2.ServerXMLHTTP
Dim re As Object 'VBScript.RegExp
Dim mc As Object 'RegExp.Match
Dim ws As Worksheet 'データ書き出しSheet
Dim flg As Boolean 'LoopOut判定FLG
Dim url As String 'URLアドレス
Dim ret As String 'XMLHTTP.responsetext
Dim s(7) As String 'URL構成文字列
Dim dX As Long '期間日数
Dim n As Long 'chk文字存在判定
Dim x As Long 'HTML項目Loop用
Dim cnt As Long 'データCOUNT
Dim i As Long
Dim j As Long
Dim k As Long
Dim v, w 'データ格納用配列,列項目名分割用配列
Dim cd '銘柄Loop用
On Error Resume Next
Set xh = CreateObject("MSXML2.ServerXMLHTTP")
On Error GoTo 0
If xh Is Nothing Then Exit Sub
On Error GoTo errHndlr
'開始日より1ページ多目に
dTMP = DateAdd("d", -50, dCHK)
s(1) = "c=" & Year(dTMP) '開始年
s(2) = "a=" & Month(dTMP) '開始月
s(3) = "b=" & Day(dTMP) '開始日
s(4) = "f=" & Year(dDate) '現在年
s(5) = "d=" & Month(dDate) '現在月
s(6) = "e=" & Day(dDate) '現在日
s(7) = "g=d&q=t&y="
dX = CLng(dDate - dCHK) + 1
'期間日数から配列の大きさを設定(+1がちょっと肝)
ReDim v(1 To dX + 1, 1 To CX)
w = Split(FLD)
Set re = CreateObject("VBScript.RegExp")
re.Pattern = PTN
re.Global = True
'コード範囲をLoop
For Each cd In cds
s(0) = "http://table.yahoo.co.jp/t?s=" & cd
url = Join(s, "&")
cnt = 1
For i = 0 To dX Step 50
xh.Open "GET", url & i, False
xh.Send
If (xh.Status >= 200) And (xh.Status < 300) Then
ret = xh.responsetext
n = InStr(ret, CHK)
If n = 0 Then Exit For
ret = Mid$(ret, n + Len(CHK))
Set mc = re.Execute(ret)
x = 0
For j = 1 + i To 50 + i
cnt = j
For k = 1 To CX
v(j, k) = mc(x).submatches(0)
'データ終了判定
If k = 1 Then
flg = IsDate(v(j, 1))
If flg Then
v(j, 1) = CDate(v(j, 1))
flg = (v(j, 1) >= dCHK)
End If
If Not flg Then
j = i + 50
i = dX
Exit For
End If
End If
x = x + 1
Next
Next
End If
Next
On Error GoTo shtAdd
Set ws = Sheets(CStr(cd))
On Error GoTo errHndlr
With ws
'データ書き出し
.Cells(.Rows.Count, 1).End(xlUp).Offset(1).Resize(cnt - 1, CX).Value = v
.Range("A1").CurrentRegion.Sort Key1:=.Range("A2"), _
Order1:=xlDescending, _
Header:=xlYes, _
OrderCustom:=1, _
MatchCase:=True, _
Orientation:=xlSortColumns, _
SortMethod:=xlStroke
End With
Next
errHndlr:
Set mc = Nothing
Set re = Nothing
Set xh = Nothing
With Err()
If .Number <> 0 Then
MsgBox .Number & vbLf & .Description
End If
End With
Exit Sub
shtAdd:
'新規コード時Sheet追加
With Sheets.Add
.Name = CStr(cd)
.Columns(1).NumberFormat = "yyyy/mm/dd"
.Range("A1").Resize(, CX).Value = w
End With
Resume
End Sub
'---------------------------------------------------------------------
No.3
- 回答日時:
致命的ミス発見orz
> On Error GoTo shtAdd
> Set ws = Sheets(CStr(cd))
> On Error GoTo errHndlr
> With ws
> 'データ書き出し
> .Cells(.Rows.Count, 1).End(xlUp).Offset(1).Resize(cnt - 1, CX).Value = v
> .Range("A1").CurrentRegion.Sort Key1:=.Range("A2"), _
> Order1:=xlDescending, _
> Header:=xlYes, _
> OrderCustom:=1, _
> MatchCase:=True, _
> Orientation:=xlSortColumns, _
> SortMethod:=xlStroke
> End With
> Next
>
>errHndlr:
> Set mc = Nothing
> Set re = Nothing
> Set xh = Nothing
> With Err()
> If .Number <> 0 Then
> MsgBox .Number & vbLf & .Description
> End If
> End With
> Exit Sub
>
>shtAdd:
> '新規コード時Sheet追加
> With Sheets.Add
> .Name = CStr(cd)
> .Columns(1).NumberFormat = "yyyy/mm/dd"
> .Range("A1").Resize(, CX).Value = w
> End With
> Resume
>End Sub
差し替えです。
If cnt > 1 Then
On Error Resume Next
Set ws = Sheets(CStr(cd))
'新規コード時Sheet追加
If ws Is Nothing Then
Set ws = Sheets.Add
ws.Name = CStr(cd)
ws.Columns(1).NumberFormat = "yyyy/mm/dd"
ws.Range("A1").Resize(, CX).Value = w
End If
On Error GoTo errHndlr
With ws
'データ書き出し
.Cells(.Rows.Count, 1).End(xlUp).Offset(1).Resize(cnt - 1, CX).Value = v
.Range("A1").CurrentRegion.Sort Key1:=.Range("A2"), _
Order1:=xlDescending, _
Header:=xlYes, _
OrderCustom:=1, _
MatchCase:=True, _
Orientation:=xlSortColumns, _
SortMethod:=xlStroke
End With
End If
Next
errHndlr:
Set mc = Nothing
Set re = Nothing
Set xh = Nothing
With Err()
If .Number <> 0 Then
MsgBox .Number & vbLf & .Description
End If
End With
End Sub
No.4
- 回答日時:
>With ws
> 'データ書き出し
> .Cells(.Rows.Count, 1).End(xlUp).Offset(1).Resize(cnt - 1, CX).Value = v
> .Range("A1").CurrentRegion.Sort Key1:=.Range("A2"), _
> Order1:=xlDescending, _
> Header:=xlYes, _
> OrderCustom:=1, _
> MatchCase:=True, _
> Orientation:=xlSortColumns, _
> SortMethod:=xlStroke
>End With
この後に
Set ws = Nothing
入れてください。
#やっぱ修行が足りんです XD
この回答へのお礼
お礼日時:2009/09/12 22:57
ご回答ありがとうございます。
早速マクロ走らせてみました。
素晴らしい、バッチリです!!
追加仕様まで付けていただきとても感謝しています。
取り込み頻度が毎日なので、非常に助かりますm(__)m
本当にありがとうございます。
お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!
似たような質問が見つかりました
- Excel(エクセル) 【困っています】VBA 追加処理の記述を教えてください。 1 2022/08/25 22:54
- Excel(エクセル) excelの列幅高さが勝手に変わる(特定のPCだけ) 8 2022/07/14 16:51
- Visual Basic(VBA) 【困っています2】VBA 追加処理の記述を教えてください。 2 2022/08/26 11:42
- その他(プログラミング・Web制作) pythonでクラスで複数のメソッドを利用する方法 2 2022/04/15 04:17
- その他(Microsoft Office) マクロVBAについて 1 2022/09/06 18:12
- 日本株 楽天RSS2での移動平均の取得について 1 2022/07/28 21:48
- Visual Basic(VBA) マクロを教えてください。 7 2023/06/01 19:47
- Excel(エクセル) マクロか関数で処理したいのですが、教えて頂けませんか。 8 2022/10/31 15:18
- Visual Basic(VBA) Excel VBA 最終行を取得しVlookup関数をコピーする方法をコーディングで教えてください。 3 2023/05/11 13:14
- Excel(エクセル) Excelについて教えてください。 帳票データがあります。 アクセスに取り込むため、 データ形式にし 1 2022/06/08 19:59
関連するカテゴリからQ&Aを探す
おすすめ情報
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
ExcelのINDEXとMATCH関数でスピ...
-
array関数で格納した配列の型を...
-
Excelのセルの色指定をVBAから...
-
エクセルで、絶対値の平均を算...
-
16進数から2進数へ
-
VBA listBoxについて
-
C#でFontStyleの列挙体に値を追...
-
フォームから値の取得(BinaryR...
-
[エクセル]連続する指定範囲か...
-
DataSetから、DataTableを取得...
-
表にフィルターをかけ、絞った...
-
Excelのオートフィルタで抽出し...
-
配列のSession格納、及び取得方...
-
VBA 配列に格納した値の平均の...
-
ショッピングカートの合計金額...
-
Excel VBA 配列の分割について
-
MFC コンボボックスを複数扱う
-
数字配列データを画像に変換す...
-
VBAでの100万行以上のデータの...
-
スプレットシートのGetTextにつ...
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
Excelのセルの色指定をVBAから...
-
ExcelのINDEXとMATCH関数でスピ...
-
array関数で格納した配列の型を...
-
[エクセル]連続する指定範囲か...
-
表にフィルターをかけ、絞った...
-
VBA listBoxについて
-
エクセルで、絶対値の平均を算...
-
配列がとびとびである場合の書き方
-
DataSetから、DataTableを取得...
-
[VBA]改行入りのセルの値を配列...
-
VBA 配列に格納した値の平均の...
-
配列のSession格納、及び取得方...
-
【VBA】ユーザーフォーム リス...
-
エクセルでエラーを無視して一...
-
SUMPRODUCT関数を用いた最小値
-
Excel VBA 配列の分割について
-
Excelのオートフィルタで抽出し...
-
VB6.0 ファイルの一括読込み
-
Excel オートフィルタのリスト...
-
VBAで指定期間の範囲を抽出し、...
おすすめ情報