将多个CSV文件从Internet导入Excel
我使用此代码检索大约40个股票代码的历史股价。我在这里找到的 在运行时错误“1004”弹出之前,它下载了大约一半的符号。“无法打开internet站点报告找不到您请求的项目(HTTP/1.0 404) 我可以更改代码以避免发生此错误吗?代码如下所示将多个CSV文件从Internet导入Excel,excel,yahoo-finance,vba,Excel,Yahoo Finance,Vba,我使用此代码检索大约40个股票代码的历史股价。我在这里找到的 在运行时错误“1004”弹出之前,它下载了大约一半的符号。“无法打开internet站点报告找不到您请求的项目(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
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
编辑:下面的代码修复了您报告的问题,但很快就耗尽了内存。我已经创建了另一个答案,我认为它更好、更可靠 服务器似乎无法识别您的查询。如果遇到此类错误,您可以添加一些错误检查以继续
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地址加载到我的浏览器中以确保其有效,然后脚本工作。我还确保项目中没有其他工作表。H下面是VBA编辑器的屏幕截图以及断点的位置:
您可以将变量粘贴到手表窗口中,然后胡闹看看它的功能。如果您为此提供了任何应用程序,我很想了解它们!我无法让您的方法正常工作(在几个100秒的滴答声后,我会出现内存不足的错误) 因此,我感兴趣并进一步挖掘。下面我提出了另一种更复杂但效果更好的方法(我在3分钟内上传了500支标准普尔股票(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
选项显式
私有声明子睡眠库“kernel32”(ByVal dw毫秒长)
专用声明函数URLDownloadToCacheFile Lib“urlmon”_
别名“URLLdownloadtocachefilea”(ByVal lpUnkcaller,长度为_
ByVal szURL作为字符串,ByVal szFileName作为字符串_
ByVal DWB长度等于长,ByVal DWB保留长度等于长_
ByVal IBindStatusCallback尽可能长)尽可能长
公共子运行批处理()
'假设有一个名为“输入”的工作表,共有3列:
'股票代码,开始日期,结束日期
'实际数据从第2行开始
Dim tickerData作为变体
作为字符串的Dim-ticker
将url设置为字符串
我想我会坚持多久
Dim yahooData作为变体
关于错误转到错误处理程序
Application.ScreenUpdating=False
tickerData=Sheets(“输入”)。UsedRange
对于i=LBound(tickerData,1)+1到UBound(tickerData,1)”,跳过第一行
ticker=tickerData(i,1)
url=getYahooUrl(ticker,tickerData(i,2),tickerData(i,3))
yahooData=getCsvContent(url)
如果是空的(yahooData),那么
MsgBox“未找到“+股票代码”的数据
其他的
copyDataToSheet yahooData,股票代码
如果结束
接下来我
Application.ScreenUpdating=True
出口接头
错误\u处理程序:
MsgBox“读取ticker[“+ticker+”]时发现错误:“+Err.Description
Application.ScreenUpdating=True
端接头
私有函数getYahooUrl(ByVal ticker作为字符串,ByVal startDate作为日期,ByVal endDate作为日期)作为字符串
像线一样变暗
将b变暗为字符串
作为字符串的Dim c
将d变暗为字符串
像线一样变暗
作为字符串的Dim f
a=格式(月(起始日期)-1,“00”)月减1
b=天(起始日期)
c=年份(起始日期)
d=格式(月(截止日期)-1,“00”)
e=天(结束日期)
f=年份(截止日期)
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”
端函数
私有函数getCsvContent(url作为字符串)作为变量
Const RETRY_NUMS As Long=3'在放弃之前,我们有多少次重试下载
将文件名设置为字符串
我想我会坚持多久
对于i=1重试\u NUMS
szFileName=Space$(300)
如果URLDownloadToCacheFile(0,url,szFileName,Len(szFileName),0,0)=0,则
getCsvContent=getDataFromFile(修剪(szFileName),“,”)
终止Trim(szFileName)“”以确保下次刷新数据
退出功能
如果结束
睡眠(500)
接下来我
端函数
私有子copyDataToSheet(数据作为变量,sheetName作为字符串)
如果不是工作表列表(sheetName),则
Worksheets.Add.Name=图纸名称
如果结束
带图纸(图纸名称)
.Cells.ClearContents
.单元格(1,1).调整大小(UBound(数据,1),UBound(数据,2))=数据
.列(1).NumberFormat=“d-mmm-yy”
.列(“A:F”).自动拟合
以
端接头
私有函数工作表列表(sheetName为字符串,可选WhichBook为工作簿)为布尔值'
“来自奇普·皮尔森
将WB设置为工作簿
设置WB=IIf(WhichBook什么都不是,thishworkbook,WhichBook)
出错时继续下一步
WorksheetExists=CBool(Len(WB.Worksheets(sheetName).Name)>0)
端函数
私有函数isArrayEmpty(parArray作为变量)作为布尔值
'如果不是未初始化(ReDim)或已擦除(Erase)的数组或动态数组,则返回false
如果IsArray(parArray)=False,则isArrayEmpty=True
出错时继续下一步
如果UBound(parArray)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