Attribute VB_Name = "gy04_day" ' 各銘柄の日足データと財務情報を取得するためのクエリファイルを作成する ' 入力ファイル："C:\mysql\mysqldata\csv\gy01_corpgrp.csv" Option Base 1 Sub gy04_day() '警告の表示を停止 Application.DisplayAlerts = False ' CSVファイル高速読み込み。CSVファイルをTXTファイルでSheet1に開く Dim corp_list(5000, 3) As String ' 行数5000列数3を確保する(カラム数は正確に) Dim list_idx As Integer ' 会社リストファイルの会社コード数 Const csv_dir As String = "C:\mysql\mysqldata\csv" ' CSVファイルのディレクトリ Const read_csv_name As String = "gy01_corpgrp.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), corp_list(list_idx, 3) list_idx = list_idx + 1 Loop Close #1 ' セルに書き込み。必要なのは第１フィールド ' Sheets("Sheet1").Range(Cells(1, 1), Cells(list_idx - 1, 1)).Value = corp_list ' ---------------------------------------------------------------------------------------- Dim corp_paste_row As Integer corp_paste_row = 1 ix = 0 Do While ix * 50 < list_idx ' シートのクリア Sheets("Sheet1").Cells.ClearContents ' WEBクエリで各銘柄の日足データを取得する With ActiveSheet.QueryTables.Add(Connection:= _ "URL;http://quote.yahoo.co.jp/q?s=" _ & corp_list((ix * 50) + 1, 1) & "+" & corp_list((ix * 50) + 2, 1) & "+" & corp_list((ix * 50) + 3, 1) & "+" & corp_list((ix * 50) + 4, 1) & "+" _ & corp_list((ix * 50) + 5, 1) & "+" & corp_list((ix * 50) + 6, 1) & "+" & corp_list((ix * 50) + 7, 1) & "+" & corp_list((ix * 50) + 8, 1) & "+" _ & corp_list((ix * 50) + 9, 1) & "+" & corp_list((ix * 50) + 10, 1) & "+" & corp_list((ix * 50) + 11, 1) & "+" & corp_list((ix * 50) + 12, 1) & "+" _ & corp_list((ix * 50) + 13, 1) & "+" & corp_list((ix * 50) + 14, 1) & "+" & corp_list((ix * 50) + 15, 1) & "+" & corp_list((ix * 50) + 16, 1) & "+" _ & corp_list((ix * 50) + 17, 1) & "+" & corp_list((ix * 50) + 18, 1) & "+" & corp_list((ix * 50) + 19, 1) & "+" & corp_list((ix * 50) + 20, 1) & "+" _ & corp_list((ix * 50) + 21, 1) & "+" & corp_list((ix * 50) + 22, 1) & "+" & corp_list((ix * 50) + 23, 1) & "+" & corp_list((ix * 50) + 24, 1) & "+" _ & corp_list((ix * 50) + 25, 1) & "+" & corp_list((ix * 50) + 26, 1) & "+" & corp_list((ix * 50) + 27, 1) & "+" & corp_list((ix * 50) + 28, 1) & "+" _ & corp_list((ix * 50) + 29, 1) & "+" & corp_list((ix * 50) + 30, 1) & "+" & corp_list((ix * 50) + 31, 1) & "+" & corp_list((ix * 50) + 32, 1) & "+" _ & corp_list((ix * 50) + 33, 1) & "+" & corp_list((ix * 50) + 34, 1) & "+" & corp_list((ix * 50) + 35, 1) & "+" & corp_list((ix * 50) + 36, 1) & "+" _ & corp_list((ix * 50) + 37, 1) & "+" & corp_list((ix * 50) + 38, 1) & "+" & corp_list((ix * 50) + 39, 1) & "+" & corp_list((ix * 50) + 40, 1) & "+" _ & corp_list((ix * 50) + 41, 1) & "+" & corp_list((ix * 50) + 42, 1) & "+" & corp_list((ix * 50) + 43, 1) & "+" & corp_list((ix * 50) + 44, 1) & "+" _ & corp_list((ix * 50) + 45, 1) & "+" & corp_list((ix * 50) + 46, 1) & "+" & corp_list((ix * 50) + 47, 1) & "+" & corp_list((ix * 50) + 48, 1) & "+" _ & corp_list((ix * 50) + 49, 1) & "+" & corp_list((ix * 50) + 50, 1) & "&d=v2", _ Destination:=Sheets("Sheet1").Range("A1")) .FieldNames = True .RowNumbers = False .FillAdjacentFormulas = False .PreserveFormatting = True .RefreshOnFileOpen = False .BackgroundQuery = True .RefreshStyle = xlInsertDeleteCells .SavePassword = False .SaveData = True .AdjustColumnWidth = True .RefreshPeriod = 0 .WebSelectionType = xlAllTables .WebFormatting = xlWebFormattingNone .WebPreFormattedTextToColumns = True .WebConsecutiveDelimitersAsOne = True .WebSingleBlockTextImport = False .WebDisableDateRecognition = False .Refresh BackgroundQuery:=False End With ' ------------------------------------------------------------------------------------------ ' WEBデータを加工して"Sheet2"へ Dim start_point01 As Integer Dim end_point01 As Integer ' 文字列「コード」の検索 Range("A8:A20").Select Selection.Find(What:="コード", After:=ActiveCell, LookIn:=xlFormulas, _ LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _ MatchCase:=False).Activate start_point01 = ActiveCell.Row + 1 '最初の銘柄コードの行を取得 ' 文字列「ニュース」の検索 Set news_str = Sheets("Sheet1").Range("A8:A150").Find(What:="ニュース", _ After:=ActiveCell, LookIn:=xlFormulas, _ LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _ MatchCase:=False) '.Activate ' 文字列「ニュース」がない場合は、文字列「ご注意」の検索 If Not news_str Is Nothing Then Sheets("Sheet1").Range("A8:A150").Find(What:="ご注意", After:=ActiveCell, LookIn:=xlFormulas, _ LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _ MatchCase:=False).Activate End If end_point01 = ActiveCell.Row - 1 '最初の銘柄コードの行を取得 For Each corp_code_cell In Sheets("Sheet1").Range(Cells(start_point01, 1), Cells(end_point01, 1)) If IsNumeric(corp_code_cell) = True And corp_code_cell > 0 Then Range(Cells(corp_code_cell.Row, 1), Cells(corp_code_cell.Row, 10)).Select Selection.Copy Sheets("Sheet2").Select Range(Cells(corp_paste_row, 1), Cells(corp_paste_row, 10)).Select ActiveSheet.Paste corp_paste_row = corp_paste_row + 1 Sheets("Sheet1").Select End If Next corp_code_cell ix = ix + 1 Loop ' ------------------------------------------------------------------------------------------ ' 日付の書式を変更 Sheets("Sheet2").Columns("C:C").NumberFormatLocal = "yyyy/m/d" ' カンマを削除 Sheets("Sheet2").Columns("D:E").NumberFormatLocal = "0_ " Sheets("Sheet2").Columns("G:J").NumberFormatLocal = "0_ " ' ファイル名を日付にしてCSV形式で保存 'Sheets("Sheet2").Name = Date$ Sheets("Sheet2").Select ' ChDir csv_dir ActiveWorkbook.SaveAs Filename:=csv_dir & "\" & "yd" & Mid(Date$, 1, 4) & Mid(Date$, 6, 2) & Mid(Date$, 9, 2) & ".csv", _ FileFormat:=xlCSV, CreateBackup:=False 'Sheets("yd" & Mid(Date$, 1, 4) & Mid(Date$, 6, 2) & Mid(Date$, 9, 2)).Name = "Sheet2" ' ------------------------------------------------------------------------------------------ End Sub