輸入複数のCSVファイルからインターネットエクセル
-
28-10-2019 - |
質問
その結果が、先ほど任天堂さんのコードを取得する歴史的株価は約40ティッカーそこちら http://www.mathfinance.cn/download-multiple-stock-quotes-from-yahoo-finance
でダウンロードの約半分の記号の前に実行時エラー'1004'を出します。"がopen http://table.finance.yahoo.com/table.csv?s=Tickersymbol&a=11&b=21&c=1998 のインターネットサイトレポートの項目では見られないHTTP/1.0 404)
変更したいのでコードでこのエラーにな失業が生まれるのでしょうか。のコードを紹介しましょう
Sub Get_Yahoo_finance()
Dim Sh As Worksheet
Dim Rng As Range
Dim Cell As Range
Dim Ticker As String
Dim StartDate As Date
Dim EndDate As Date
Dim a, b, c, d, e, f
Dim StrURL As String
Set Sh = Worksheets("Input")
Set Rng = Sh.Range("A2:A" & Sh.Range("A65536").End(xlUp).Row)
For Each Cell In Rng
Ticker = Cell.Value
StartDate = Cell.Offset(0, 1).Value
EndDate = Cell.Offset(0, 2).Value
a = Format(Month(StartDate) - 1, "00") ' Month minus 1
b = Day(StartDate)
c = Year(StartDate)
d = Format(Month(EndDate) - 1, "00")
e = Day(EndDate)
f = Year(EndDate)
StrURL = "URL;http://table.finance.yahoo.com/table.csv?"
StrURL = StrURL & "s=" & Ticker & "&a=" & a & "&b=" & b
StrURL = StrURL & "&c=" & c & "&d=" & d & "&e=" & e
StrURL = StrURL & "&f=" & f & "&g=d&ignore=.csv"
If WorksheetExists(Ticker, ActiveWorkbook) Then
Application.DisplayAlerts = False
Sheets(Ticker).Select
ActiveWindow.SelectedSheets.Delete
ActiveWorkbook.Worksheets.Add.Name = Ticker
Else
ActiveWorkbook.Worksheets.Add.Name = Ticker
End If
With ActiveSheet.QueryTables.Add(Connection:=StrURL, Destination:=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
Columns("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
:=Array(Array(1, 4), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
Array(7, 1))
Range("A2").Select
Range(Selection, Selection.End(xlDown)).NumberFormat = "d-mmm-yy"
Columns("A:F").EntireColumn.AutoFit
Next Cell
End Sub
Function WorksheetExists(SheetName As String, _
Optional WhichBook As Workbook) As Boolean
'from Chip Pearson
Dim WB As Workbook
Set WB = IIf(WhichBook Is Nothing, ThisWorkbook, WhichBook)
On Error Resume Next
WorksheetExists = CBool(Len(WB.Worksheets(SheetName).Name) > 0)
End Function
解決
あなたの方法を適切に動作させることはできません(数百人のティッカーの後、メモリエラーから抜け出します)。
だから私は興味を持ち、もう少し掘りました。以下の別のアプローチを提案しますが、より複雑ですが、より良い結果が得られます(S&Pの500株を3分でアップロードしました(Excelの実際のジョブで約3秒、残りは接続 /ダウンロード時間です)。コピー全体をコピーするだけです。モジュールでコードして実行します runBatch
手順。
Option Explicit
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMillisecond As Long)
Private Declare Function URLDownloadToCacheFile Lib "urlmon" _
Alias "URLDownloadToCacheFileA" (ByVal lpUnkcaller As Long, _
ByVal szURL As String, ByVal szFileName As String, _
ByVal dwBufLength As Long, ByVal dwReserved As Long, _
ByVal IBindStatusCallback As Long) As Long
Public Sub runBatch()
'Assumes there is a sheet called "Input" with 3 columns:
'Ticker, Start Date, End Date
'Actual data starts from Row 2
Dim tickerData As Variant
Dim ticker As String
Dim url As String
Dim i As Long
Dim yahooData As Variant
On Error GoTo error_handler
Application.ScreenUpdating = False
tickerData = Sheets("Input").UsedRange
For i = LBound(tickerData, 1) + 1 To UBound(tickerData, 1) 'skip first row
ticker = tickerData(i, 1)
url = getYahooUrl(ticker, tickerData(i, 2), tickerData(i, 3))
yahooData = getCsvContent(url)
If isArrayEmpty(yahooData) Then
MsgBox "No data found for " + ticker
Else
copyDataToSheet yahooData, ticker
End If
Next i
Application.ScreenUpdating = True
Exit Sub
error_handler:
MsgBox "Error found while reading ticker [" + ticker + "]: " + Err.Description
Application.ScreenUpdating = True
End Sub
Private Function getYahooUrl(ByVal ticker As String, ByVal startDate As Date, ByVal endDate As Date) As String
Dim a As String
Dim b As String
Dim c As String
Dim d As String
Dim e As String
Dim f As String
a = Format(Month(startDate) - 1, "00") ' Month minus 1
b = Day(startDate)
c = Year(startDate)
d = Format(Month(endDate) - 1, "00")
e = Day(endDate)
f = Year(endDate)
getYahooUrl = "http://table.finance.yahoo.com/table.csv?" & _
"s=" & ticker & "&" & _
"a=" & a & "&" & _
"b=" & b & "&" & _
"c=" & c & "&" & _
"d=" & d & "&" & _
"e=" & e & "&" & _
"f=" & f & "&" & _
"g=d&ignore=.csv"
End Function
Private Function getCsvContent(url As String) As Variant
Const RETRY_NUMS As Long = 3 'How m any times do we retry the download before giving up
Dim szFileName As String
Dim i As Long
For i = 1 To RETRY_NUMS
szFileName = Space$(300)
If URLDownloadToCacheFile(0, url, szFileName, Len(szFileName), 0, 0) = 0 Then
getCsvContent = getDataFromFile(Trim(szFileName), ",")
Kill Trim(szFileName) 'to make sure data is refreshed next time
Exit Function
End If
Sleep (500)
Next i
End Function
Private Sub copyDataToSheet(data As Variant, sheetName As String)
If Not WorksheetExists(sheetName) Then
Worksheets.Add.Name = sheetName
End If
With Sheets(sheetName)
.Cells.ClearContents
.Cells(1, 1).Resize(UBound(data, 1), UBound(data, 2)) = data
.Columns(1).NumberFormat = "d-mmm-yy"
.Columns("A:F").AutoFit
End With
End Sub
Private Function WorksheetExists(sheetName As String, Optional WhichBook As Workbook) As Boolean '
'from Chip Pearson
Dim WB As Workbook
Set WB = IIf(WhichBook Is Nothing, ThisWorkbook, WhichBook)
On Error Resume Next
WorksheetExists = CBool(Len(WB.Worksheets(sheetName).Name) > 0)
End Function
Private Function isArrayEmpty(parArray As Variant) As Boolean
'Returns false if not an array or dynamic array that has not been initialised (ReDim) or has been erased (Erase)
If IsArray(parArray) = False Then isArrayEmpty = True
On Error Resume Next
If UBound(parArray) < LBound(parArray) Then isArrayEmpty = True: Exit Function Else: isArrayEmpty = False
End Function
Private Function getDataFromFile(parFileName As String, parDelimiter As String, Optional parExcludeCharacter As String = "") As Variant 'V.20081021
'parFileName is supposed to be a delimited file (csv...)
'Returns an empty array if file is empty or can't be opened
'20081021: number of columns based on the line with the largest number of columns, not on the first line
' parExcludeCharacter: sometimes csv files have quotes around strings: "XXX" - if parExcludeCharacter = """" then removes the quotes
'20081022: Error Checks in place
Dim locLinesList() As Variant
Dim locData As Variant
Dim i As Long
Dim j As Long
Dim locNumRows As Long
Dim locNumCols As Long
Dim fso As Variant
Dim ts As Variant
Const REDIM_STEP = 10000
Set fso = CreateObject("Scripting.FileSystemObject")
On Error GoTo error_open_file
Set ts = fso.OpenTextFile(parFileName)
On Error GoTo unhandled_error
'Counts the number of lines and the largest number of columns
ReDim locLinesList(1 To 1) As Variant
i = 0
Do While Not ts.AtEndOfStream
If i Mod REDIM_STEP = 0 Then
ReDim Preserve locLinesList(1 To UBound(locLinesList, 1) + REDIM_STEP) As Variant
End If
locLinesList(i + 1) = Split(ts.ReadLine, parDelimiter)
j = UBound(locLinesList(i + 1), 1) 'number of columns
If locNumCols < j Then locNumCols = j
i = i + 1
Loop
ts.Close
locNumRows = i
If locNumRows = 0 Then Exit Function 'Empty file
ReDim locData(1 To locNumRows, 1 To locNumCols + 1) As Variant
'Copies the file into an array
If parExcludeCharacter <> "" Then
For i = 1 To locNumRows
For j = 0 To UBound(locLinesList(i), 1)
If Left(locLinesList(i)(j), 1) = parExcludeCharacter Then
If Right(locLinesList(i)(j), 1) = parExcludeCharacter Then
locLinesList(i)(j) = Mid(locLinesList(i)(j), 2, Len(locLinesList(i)(j)) - 2) 'If locTempArray = "", Mid returns ""
Else
locLinesList(i)(j) = Right(locLinesList(i)(j), Len(locLinesList(i)(j)) - 1)
End If
ElseIf Right(locLinesList(i)(j), 1) = parExcludeCharacter Then
locLinesList(i)(j) = Left(locLinesList(i)(j), Len(locLinesList(i)(j)) - 1)
End If
locData(i, j + 1) = locLinesList(i)(j)
Next j
Next i
Else
For i = 1 To locNumRows
For j = 0 To UBound(locLinesList(i), 1)
locData(i, j + 1) = locLinesList(i)(j)
Next j
Next i
End If
getDataFromFile = locData
Exit Function
error_open_file: 'returns empty variant
unhandled_error: 'returns empty variant
End Function
他のヒント
編集:以下のコードの修正のご報告です。私が作成したもの答えとなっていると思いくとの強固な
おかしくなってしまいそうです。クエリが認識されなかには以下のルールを適用します。を追加できるかのエラーチェックを続けるようになれば、エラーが発生します。
Sub Get_Yahoo_finance()
Dim Sh As Worksheet
Dim Rng As Range
Dim Cell As Range
Dim Ticker As String
Dim StartDate As Date
Dim EndDate As Date
Dim a, b, c, d, e, f
Dim StrURL As String
Dim errorMsg As String
Set Sh = Worksheets("Input")
Set Rng = Sh.Range("A2:A" & Sh.Range("A65536").End(xlUp).Row)
For Each Cell In Rng
Ticker = Cell.Value
StartDate = Cell.Offset(0, 1).Value
EndDate = Cell.Offset(0, 2).Value
a = Format(Month(StartDate) - 1, "00") ' Month minus 1
b = Day(StartDate)
c = Year(StartDate)
d = Format(Month(EndDate) - 1, "00")
e = Day(EndDate)
f = Year(EndDate)
StrURL = "URL;http://table.finance.yahoo.com/table.csv?"
StrURL = StrURL & "s=" & Ticker & "&a=" & a & "&b=" & b
StrURL = StrURL & "&c=" & c & "&d=" & d & "&e=" & e
StrURL = StrURL & "&f=" & f & "&g=d&ignore=.csv"
If WorksheetExists(Ticker, ActiveWorkbook) Then
Application.DisplayAlerts = False
Sheets(Ticker).Select
ActiveWindow.SelectedSheets.Delete
ActiveWorkbook.Worksheets.Add.Name = Ticker
Else
ActiveWorkbook.Worksheets.Add.Name = Ticker
End If
With ActiveSheet.QueryTables.Add(Connection:=StrURL, Destination:=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
On Error Resume Next
.Refresh BackgroundQuery:=False
errorMsg = IIf(Err.Number = 0, "", Err.Description)
On Error GoTo 0
End With
If errorMsg = "" Then
Columns("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
:=Array(Array(1, 4), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
Array(7, 1))
Range("A2").Select
Range(Selection, Selection.End(xlDown)).NumberFormat = "d-mmm-yy"
Columns("A:F").EntireColumn.AutoFit
Else
Range("A1") = errorMsg
End If
Next Cell
End Sub
Function WorksheetExists(SheetName As String, Optional WhichBook As Workbook) As Boolean '
'from Chip Pearson
Dim WB As Workbook
Set WB = IIf(WhichBook Is Nothing, ThisWorkbook, WhichBook)
On Error Resume Next
WorksheetExists = CBool(Len(WB.Worksheets(SheetName).Name) > 0)
End Function
するための削除シートのではなくエラーメッセージであるということもあり、そ送MsgBox替わり---
私は一度それを走らせました、そしてそれは失敗しました。クエリラインにブレークポイントを置き、Yahooアドレスをブラウザにロードして、それが有効であることを確認し、スクリプトが機能しました。また、プロジェクトに他のワークシートがないことを確認しました。これがVBAエディターのスクリーンショットと、ブレークポイントがどこに行くのかを示します。
変数を時計ウィンドウに貼り付けてから、それを馬鹿にして、それが何をするかを確認できます。このためのアプリケーションを思いついたら、それらについて聞いてみたいです!
添付されているのは、ティッカーデータを最大3回取得するために変更された元のコードを使用した「よりシンプルな」ソリューションです(試行の間に数秒待っています)、最終的にメッセージボックスによる障害を認めます。私の2セント:-)
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMillisecond As Long)
Sub Get_Yahoo_finance_history()
Dim Sh As Worksheet
Dim Rng As Range
Dim Cell As Range
Dim Ticker As String
Dim StartDate As Date
Dim EndDate As Date
Dim a, b, c, d, e, f
Dim StrURL As String
Dim RetryCount As Integer
'turn calculation off
'Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
Set Sh = Worksheets("Input")
Set Rng = Sh.Range("A2:A" & Sh.Range("A65536").End(xlUp).Row)
For Each Cell In Rng
Ticker = Cell.Value
StartDate = Cell.Offset(0, 1).Value
EndDate = Cell.Offset(0, 2).Value
a = Format(Month(StartDate) - 1, "00") ' Month minus 1
b = Day(StartDate)
c = Year(StartDate)
d = Format(Month(EndDate) - 1, "00")
e = Day(EndDate)
f = Year(EndDate)
StrURL = "URL;http://table.finance.yahoo.com/table.csv?"
StrURL = StrURL & "s=" & Ticker & "&a=" & a & "&b=" & b
StrURL = StrURL & "&c=" & c & "&d=" & d & "&e=" & e
StrURL = StrURL & "&f=" & f & "&g=d&ignore=.csv"
If WorksheetExists(Ticker, ActiveWorkbook) Then
Sheets(Ticker).Select
ActiveWindow.SelectedSheets.Delete
ActiveWorkbook.Worksheets.Add.Name = Ticker
Else
ActiveWorkbook.Worksheets.Add.Name = Ticker
End If
RetryCount = 0 Retry:
If RetryCount > 3 Then
Range("A1") = errorMsg
MsgBox "After 3 attempts: Could not retrieve data for " + Ticker
End
End If
RetryCount = RetryCount + 1
With ActiveSheet.QueryTables.Add(Connection:=StrURL, Destination:=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
.WebDisableRedirections = False
On Error Resume Next
.Refresh BackgroundQuery:=False
errorMsg = IIf(Err.Number = 0, "", Err.Description)
On Error GoTo 0
End With
If errorMsg = "" Then
Columns("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
:=Array(Array(1, 4), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
Array(7, 1))
Columns("A").EntireColumn.NumberFormat = "mm/dd/yyyy"
Columns("B:E").EntireColumn.NumberFormat = "$###,##0.00"
Columns("F").EntireColumn.NumberFormat = "###,##0"
Columns("B:E").EntireColumn.NumberFormat = "$###,##0.00"
Columns("A:F").EntireColumn.AutoFit
Else
Sleep (500)
Sheets(Ticker).Cells.ClearContents
GoTo Retry
End If
Next Cell
'turn calculation back on
'Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
End Sub
Function WorksheetExists(SheetName As String, _
Optional WhichBook As Workbook) As Boolean
'from Chip Pearson
Dim WB As Workbook
Set WB = IIf(WhichBook Is Nothing, ThisWorkbook, WhichBook)
On Error Resume Next
WorksheetExists = CBool(Len(WB.Worksheets(SheetName).Name) > 0)
End Function