Attribute VB_Name = "gy03_fin" ' 各銘柄の日足データと財務情報を取得するためのクエリファイルを作成する ' 入力ファイル:"C:\mysql\mysqldata\csv\gy01_corpgrp.csv" Option Base 1 Sub gy03_fin() '警告の表示を停止 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 ' セルに書き込み。必要なのは第1フィールド ' Sheets("Sheet1").Range(Cells(1, 1), Cells(list_idx - 1, 1)).Value = corp_list ' ---------------------------------------------------------------------------------------- Dim corp_fin_data(5000, 25) As String 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=t", _ 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 current_idx As Integer Dim end_point01 As Integer ' 文字列「関連情報」の検索 Range("B8:B20").Select Selection.Find(What:="関連情報", After:=ActiveCell, LookIn:=xlFormulas, _ LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _ MatchCase:=False).Activate current_idx = ActiveCell.Row '最初の銘柄名の行を取得 ' 文字列「最新関連ニュース」の検索 Sheets("Sheet1").Range("A8:A600").Select Selection.Find(What:="最新関連ニュース", _ LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext).Activate Set news_str = Selection.Find(What:="最新関連ニュース", _ LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext) ' 文字列「最新関連ニュース」がない場合は、文字列「ご注意」の検索 If news_str Is Nothing Then Sheets("Sheet1").Range("A8:A600").Find(What:="ご注意", After:=ActiveCell, LookIn:=xlFormulas, _ LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _ MatchCase:=False).Activate End If end_point01 = ActiveCell.Row - 1 '最後の銘柄の行を取得 Sheets("Sheet1").Select Do While current_idx < end_point01 corp_fin_data(corp_paste_row, 1) = Cells(current_idx, 1).Value corp_fin_data(corp_paste_row, 2) = Cells(current_idx + 2, 1).Value corp_fin_data(corp_paste_row, 3) = Cells(current_idx + 2, 2).Value corp_fin_data(corp_paste_row, 4) = Cells(current_idx + 2, 3).Value corp_fin_data(corp_paste_row, 5) = Cells(current_idx + 2, 4).Value corp_fin_data(corp_paste_row, 6) = Cells(current_idx + 2, 5).Value corp_fin_data(corp_paste_row, 7) = Cells(current_idx + 2, 6).Value corp_fin_data(corp_paste_row, 8) = Cells(current_idx + 4, 1).Value corp_fin_data(corp_paste_row, 9) = Cells(current_idx + 4, 2).Value corp_fin_data(corp_paste_row, 10) = Cells(current_idx + 4, 3).Value corp_fin_data(corp_paste_row, 11) = Cells(current_idx + 4, 4).Value corp_fin_data(corp_paste_row, 12) = Cells(current_idx + 4, 5).Value corp_fin_data(corp_paste_row, 13) = Cells(current_idx + 4, 6).Value corp_fin_data(corp_paste_row, 14) = Cells(current_idx + 6, 1).Value corp_fin_data(corp_paste_row, 15) = Cells(current_idx + 6, 2).Value corp_fin_data(corp_paste_row, 16) = Cells(current_idx + 6, 3).Value corp_fin_data(corp_paste_row, 17) = Cells(current_idx + 6, 4).Value corp_fin_data(corp_paste_row, 18) = Cells(current_idx + 6, 5).Value corp_fin_data(corp_paste_row, 19) = Cells(current_idx + 6, 6).Value corp_fin_data(corp_paste_row, 20) = Cells(current_idx + 8, 1).Value corp_fin_data(corp_paste_row, 21) = Cells(current_idx + 8, 2).Value corp_fin_data(corp_paste_row, 22) = Cells(current_idx + 8, 3).Value corp_fin_data(corp_paste_row, 23) = Cells(current_idx + 8, 4).Value corp_fin_data(corp_paste_row, 24) = Cells(current_idx + 8, 5).Value corp_fin_data(corp_paste_row, 25) = Cells(current_idx + 8, 6).Value current_idx = current_idx + 10 corp_paste_row = corp_paste_row + 1 Loop ix = ix + 1 Loop ' セルに書き込み Sheets("Sheet2").Select Range(Cells(1, 1), Cells(corp_paste_row - 1, 25)).Value = corp_fin_data ' ------------------------------------------------------------------------------------------ ' ファイル名を日付にしてCSV形式で保存 'Sheets("Sheet2").Name = Date$ Sheets("Sheet2").Select ' ChDir csv_dir ActiveWorkbook.SaveAs Filename:=csv_dir & "\" & "yf" & Mid(Date$, 1, 4) & Mid(Date$, 6, 2) & Mid(Date$, 9, 2) & ".csv", _ FileFormat:=xlCSV, CreateBackup:=False ' シート名を元に戻す Sheets("yf" & Mid(Date$, 1, 4) & Mid(Date$, 6, 2) & Mid(Date$, 9, 2)).Name = "Sheet2" ' ------------------------------------------------------------------------------------------ End Sub