Attribute VB_Name = "gy07_period" ' 各銘柄の時系列データと財務情報を取得するためのクエリファイルを作成する ' 入力ファイル："C:\mysql\mysqldata\csv\bland_market_code.csv" Option Base 1 Sub gy07_period() initial_time = Timer ' 開始時刻 '警告の表示を停止 Application.DisplayAlerts = False ' ---------------------------------------------------------------------------------- ' CSVファイル高速読み込み。CSVファイルをTXTファイルでSheet1に開く Dim corp_list(5000, 2) As String ' 行数5000、列数2を確保する(カラム数は正確に) Dim list_idx As Integer ' 会社リストファイルの会社コード数 Const csv_dir As String = "C:\mysql\mysqldata\csv" ' CSVファイルのディレクトリ Const read_csv_name As String = "bland_market_code.csv" ' CSVファイル名 If Dir(csv_dir & "\" & read_csv_name) <> read_csv_name Then MsgBox "ファイル「" & read_csv_name & "」はありません" Exit Sub End If Application.StatusBar = "( " & read_csv_name & " )読み込み中" ' CSVファイル読み込み list_idx = 1 Open csv_dir & "\" & read_csv_name For Input As #1 Do Until EOF(1) Input #1, corp_list(list_idx, 1), corp_list(list_idx, 2) list_idx = list_idx + 1 Loop Close #1 ' セルに書き込み。必要なのは第１フィールド ' Sheets("Sheet1").Range(Cells(1, 1), Cells(list_idx - 1, 1)).Value = corp_list ' ---------------------------------------------------------------------------------------- Dim ix As Integer Dim corp_paste_row As Integer Dim corp_day_data(65000, 7) As String Dim page_num As Integer Dim retention_page_flag As Boolean Dim start_point01 As Integer Dim end_point01 As Integer page_num = 0 ix = 1 Do While ix < list_idx corp_paste_row = 1 If retention_page = False Then page_num = 0 retention_page = False Sheets("Sheet1").select Do While corp_paste_row < 64000 ' シートのクリア Sheets("Sheet1").Cells.ClearContents If corp_list(ix, 2) = "x" Then corp_list(ix, 2) = "" ' WEBクエリで各銘柄の時系列データを取得する With Sheets("Sheet1").QueryTables.Add(Connection:= _ "URL;http://chart.yahoo.co.jp/t?c=1970&a=1&b=1&f=2003&d=10&e=31&g=d&s=" _ & corp_list(ix, 1) & "." & corp_list(ix, 2) & "&y=" & page_num & "&z=" & corp_list(ix, 1) & "." & corp_list(ix, 2), _ Destination:=Sheets("Sheet1").Range("A1")) .FieldNames = True .RowNumbers = False .FillAdjacentFormulas = False .PreserveFormatting = True .RefreshOnFileOpen = False .BackgroundQuery = True .RefreshStyle = xlInsertDeleteCells .SavePassword = False .SaveData = True .AdjustColumnWidth = False .RefreshPeriod = 0 .WebSelectionType = xlAllTables .WebFormatting = xlWebFormattingNone .WebPreFormattedTextToColumns = True .WebConsecutiveDelimitersAsOne = True .WebSingleBlockTextImport = False .WebDisableDateRecognition = False .Refresh BackgroundQuery:=False End With ' ------------------------------------------------------------------------------------------ ' WEBデータを加工して"Sheet2"へ ' 文字列「日付」の検索 Sheets("Sheet1").Range("A13:A20").select Set start_cell = selection.Find(What:="日付", After:=ActiveCell, LookIn:=xlFormulas, _ LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext) ' WEBページが文字化けしていた場合は、株価を直接検索する。 If start_cell Is Nothing Then For Each get_num_cell In Range("B15:B22") If IsNumeric(get_num_cell) = True Then start_point01 = ActiveCell.Row '最初の銘柄コードの行を取得 Exit For End If Next get_num_cell Else start_point01 = start_cell.Row + 1 '最初の銘柄コードの行を取得 End If '最初の銘柄コードの行に「前の*件」がある場合は終了 If Not (Sheets("Sheet1").Cells(start_point01, 1).Find(What:="前の*件", LookAt:=xlPart) Is Nothing) Then Exit Do End If ' 文字列「次の*件」の検索 Sheets("Sheet1").Range(Cells(start_point01, 1), Cells(100, 1)).select Set end_cell = selection.Find(What:="次の*件", _ LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext) ' WEBページが文字化けしていた場合は、株価を直接検索する。 If end_cell Is Nothing Then For Each get_num_cell In Range(Cells(start_point01, 1), Cells(100, 1)) If IsNumeric(get_num_cell) = False Then end_point01 = ActiveCell.Row - 1 '最後の日足データの行を取得 Exit For End If Next get_num_cell Else end_point01 = end_cell.Row - 1 '最後の日足データの行を取得 End If day_record = start_point01 Do While day_record <= end_point01 corp_day_data(corp_paste_row, 1) = Cells(day_record, 1).Value corp_day_data(corp_paste_row, 2) = Cells(day_record, 2).Value corp_day_data(corp_paste_row, 3) = Cells(day_record, 3).Value corp_day_data(corp_paste_row, 4) = Cells(day_record, 4).Value corp_day_data(corp_paste_row, 5) = Cells(day_record, 5).Value corp_day_data(corp_paste_row, 6) = Cells(day_record, 6).Value corp_day_data(corp_paste_row, 7) = Cells(day_record, 7).Value corp_paste_row = corp_paste_row + 1 day_record = day_record + 1 Loop page_num = page_num + 50 Application.StatusBar = "STATUS( " & page_num & "ページ：" _ & corp_paste_row & " レコード：" & Left(Str((Timer - initial_time) / 60), 4) & "分経過：" _ & start_point01 & "：" & end_point01 & " )" Loop ' デバッグ用 'If page_num >= 1450 Then ' MsgBox " オーバーフロー発生。", vbExclamation, "デバッグ用" 'End If If corp_paste_row >= 64000 Then ix = ix - 1 retention_page = True End If ' セルに書き込み Sheets("Sheet2").select Range(Cells(1, 1), Cells(corp_paste_row - 1, 7)).Value = corp_day_data ' データ編集 ' 注意：処理時間2倍近くかかるので、ネット接続時間を短縮するために後で処理することを推奨する ' カラムAの日付型データを8桁の整数型へ変換 'Columns("A").select 'For Each date_data_row In Range(Cells(1, 1), Cells(corp_paste_row - 1, 1)) ' date_data_row.Value = Format(date_data_row.Value, "yyyymmdd") ' date_data_row.NumberFormatLocal = "G/標準" 'Next date_data_row ' date_data_row.NumberFormatLocal = "yyyymmdd" 'Columns("A").Replace What:="'", Replacement:="", _ ' LookAt:=xlPart, SearchOrder:=xlByRows ' ------------------------------------------------------------------------------------------ ' ファイル名を日付にしてCSV形式で保存 ActiveWorkbook.SaveAs Filename:=csv_dir & "\" & "yp" & corp_list(ix, 1) & Right("00000" & page_num, 5) & ".csv", _ FileFormat:=xlCSV, CreateBackup:=False Sheets("yp" & corp_list(ix, 1) & Right("00000" & page_num, 5)).Name = "Sheet2" ' シートのクリア Sheets("Sheet2").Cells.ClearContents ' ------------------------------------------------------------------------------------------ ix = ix + 1 Loop End Sub