Attribute VB_Name = "gy02_corpinfo" ' 各銘柄の日足データと財務情報を取得するためのクエリファイルを作成する ' 入力ファイル:"C:\mysql\mysqldata\csv\gy01_corpgrp.csv" Option Base 1 Sub gy02_corpinfo() '警告の表示を停止 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 = "D:\77stock\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_fund_data(5000, 25) As String Dim corp_paste_row As Integer corp_paste_row = 1 Do While corp_paste_row < list_idx ' シートのクリア Sheets("Sheet1").Cells.ClearContents ' WEBクエリで各会社の基本情報を取得する With ActiveSheet.QueryTables.Add(Connection:= _ "URL;http://profile.yahoo.co.jp/biz/fundamental/" & corp_list(corp_paste_row, 1) & ".html", _ 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"へ ' 文字列「会社概要」の検索 Range("D5:D13").Select Selection.Find(What:="会社概要", After:=ActiveCell, LookIn:=xlFormulas, _ LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _ MatchCase:=False).Activate current_idx = ActiveCell.Row '銘柄コードの行を取得 corp_fund_data(corp_paste_row, 1) = Cells(current_idx - 3, 4).Value ' 更新日 corp_fund_data(corp_paste_row, 2) = Cells(current_idx - 3, 1).Value ' 銘柄名 corp_fund_data(corp_paste_row, 3) = Cells(current_idx + 10, 4).Value ' 従業員数(単独) corp_fund_data(corp_paste_row, 4) = Cells(current_idx + 11, 4).Value ' 従業員数(連結) corp_fund_data(corp_paste_row, 5) = Cells(current_idx + 10, 5).Value ' 平均年齢 corp_fund_data(corp_paste_row, 6) = Cells(current_idx + 11, 5).Value ' 平均年収 corp_fund_data(corp_paste_row, 7) = Cells(current_idx + 5, 5).Value ' 業種分類 corp_fund_data(corp_paste_row, 8) = Cells(current_idx + 6, 5).Value ' 市場名 corp_fund_data(corp_paste_row, 9) = Cells(current_idx + 7, 5).Value ' 中間配当 corp_fund_data(corp_paste_row, 10) = Cells(current_idx + 8, 5).Value ' 単元株数 corp_fund_data(corp_paste_row, 11) = Cells(current_idx + 7, 4).Value ' 決算 corp_fund_data(corp_paste_row, 12) = Cells(current_idx + 8, 4).Value ' 設立年月日 corp_fund_data(corp_paste_row, 13) = Cells(current_idx + 9, 5).Value ' 上場年月日 corp_fund_data(corp_paste_row, 14) = Cells(current_idx + 9, 4).Value ' 代表者名 corp_fund_data(corp_paste_row, 15) = Cells(current_idx + 2, 4).Value ' 連結事業 corp_fund_data(corp_paste_row, 16) = Cells(current_idx + 1, 4).Value ' 特色 corp_paste_row = corp_paste_row + 1 Loop ' セルに書き込み Sheets("Sheet2").Select Range(Cells(1, 1), Cells(corp_paste_row - 1, 16)).Value = corp_fund_data ' ------------------------------------------------------------------------------------------ ' データ編集 ' 括弧を削除 Sheets("Sheet2").Columns("C:P").Replace What:="【*】", Replacement:="", LookAt:=xlPart, _ SearchOrder:=xlByRows, MatchCase:=False ' A「年」を削除 Sheets("Sheet2").Columns("A").Replace What:="年", Replacement:="", LookAt:=xlPart, _ SearchOrder:=xlByRows, MatchCase:=False ' A「月」を削除 Sheets("Sheet2").Columns("A").Replace What:="月", Replacement:="", LookAt:=xlPart, _ SearchOrder:=xlByRows, MatchCase:=False ' A「日」を削除 Sheets("Sheet2").Columns("A").Replace What:="日", Replacement:="", LookAt:=xlPart, _ SearchOrder:=xlByRows, MatchCase:=False ' A「更新」を削除 Sheets("Sheet2").Columns("A").Replace What:="更新", Replacement:="", LookAt:=xlPart, _ SearchOrder:=xlByRows, MatchCase:=False ' CD「人」を削除 Sheets("Sheet2").Columns("C:D").Replace What:="人", Replacement:="", LookAt:=xlPart, _ SearchOrder:=xlByRows, MatchCase:=False ' E「歳」を削除 Sheets("Sheet2").Columns("E").Replace What:="歳", Replacement:="", LookAt:=xlPart, _ SearchOrder:=xlByRows, MatchCase:=False ' F「千円」を「000」に置換 Sheets("Sheet2").Columns("F").Replace What:="千円", Replacement:="000", LookAt:=xlPart, _ SearchOrder:=xlByRows, MatchCase:=False ' J「株」を削除 Sheets("Sheet2").Columns("J").Replace What:="株", Replacement:="", LookAt:=xlPart, _ SearchOrder:=xlByRows, MatchCase:=False ' LM「年」を削除 Sheets("Sheet2").Columns("L:M").Replace What:="年", Replacement:="", LookAt:=xlPart, _ SearchOrder:=xlByRows, MatchCase:=False ' LM「月」を削除 Sheets("Sheet2").Columns("L:M").Replace What:="月", Replacement:="", LookAt:=xlPart, _ SearchOrder:=xlByRows, MatchCase:=False ' LM「日」を削除 Sheets("Sheet2").Columns("L:M").Replace What:="日", Replacement:="", LookAt:=xlPart, _ SearchOrder:=xlByRows, MatchCase:=False Sheets("Sheet2").Select Columns("C").Insert Shift:=xlToRight Columns("C").Insert Shift:=xlToRight Columns("C").Insert Shift:=xlToRight corp_paste_row = 1 Do While corp_paste_row < list_idx Cells(corp_paste_row, 3) = Mid(Cells(corp_paste_row, 2), 1, Len(Cells(corp_paste_row, 2)) - 6) Cells(corp_paste_row, 4) = Mid(Cells(corp_paste_row, 2), Len(Cells(corp_paste_row, 2)) - 4, 4) If Not Cells(corp_paste_row, 11).Find(What:="東証", LookIn:=xlFormulas, LookAt:=xlPart) Is Nothing Then Cells(corp_paste_row, 5) = "t" ElseIf Not Cells(corp_paste_row, 11).Find(What:="大証", LookAt:=xlPart) Is Nothing Then Cells(corp_paste_row, 5) = "o" ElseIf Not Cells(corp_paste_row, 11).Find(What:="名証", LookAt:=xlPart) Is Nothing Then Cells(corp_paste_row, 5) = "n" ElseIf Not Cells(corp_paste_row, 11).Find(What:="JASDAQ", LookAt:=xlPart) Is Nothing Then Cells(corp_paste_row, 5) = "q" ElseIf Not Cells(corp_paste_row, 11).Find(What:="店頭管理", LookAt:=xlPart) Is Nothing Then Cells(corp_paste_row, 5) = "q" ElseIf Not Cells(corp_paste_row, 11).Find(What:="マザーズ", LookAt:=xlPart) Is Nothing Then Cells(corp_paste_row, 5) = "t" ElseIf Not Cells(corp_paste_row, 11).Find(What:="ヘラクレス", LookAt:=xlPart) Is Nothing Then Cells(corp_paste_row, 5) = "j" ElseIf Not Cells(corp_paste_row, 11).Find(What:="札幌", LookAt:=xlPart) Is Nothing Then Cells(corp_paste_row, 5) = "s" Else: Cells(corp_paste_row, 5) = "x" End If corp_paste_row = corp_paste_row + 1 Loop ' オリジナルのカラムを削除 Sheets("Sheet2").Columns("B").Delete Shift:=xlToLeft ' 銘柄コードと市場コードを別のシートにコピー Sheets("Sheet3").Columns("A:B").Value = Sheets("Sheet2").Columns("C:D").Value ' 銘柄AND市場コードファイルをCSV形式で保存 Sheets("Sheet3").Select ActiveWorkbook.SaveAs Filename:=csv_dir & "\" & "bland_market_code" & ".csv", _ FileFormat:=xlCSV, CreateBackup:=False ' ファイル名を日付にしてCSV形式で保存 'Sheets("Sheet2").Name = Date$ Sheets("Sheet2").Select ' ChDir csv_dir ActiveWorkbook.SaveAs Filename:=csv_dir & "\" & "yc" & Mid(Date$, 1, 4) & Mid(Date$, 6, 2) & Mid(Date$, 9, 2) & ".csv", _ FileFormat:=xlCSV, CreateBackup:=False 'Sheets("yc" & Mid(Date$, 1, 4) & Mid(Date$, 6, 2) & Mid(Date$, 9, 2)).Name = "Sheet2" ' ------------------------------------------------------------------------------------------ End Sub