VBA源代码-Excel版本从Yahoo获得实时数据和历史数据

by faruto

此帖子和下面这个帖子相关

Excel版本从Yahoo获得实时数据和历史数据<a href="http://cnq.net/chinaquant-2911" target="_blank">http://cnq.net/chinaquant-2911</a>

下面给出上面帖子的 VBA 源代码:

代码不难,会 VBA 看看,大概就能明白了。

从 Yahoo 获得实时数据 VBA



Sub GetData()     Dim QuerySheet As Worksheet     Dim DataSheet As Worksheet     Dim qurl As String     Dim i As Integer         Application.ScreenUpdating = False     Application.DisplayAlerts = False     Application.Calculation = xlCalculationManual         Set DataSheet = ActiveSheet        Range("C7").CurrentRegion.ClearContents     i = 7     qurl = "http://download.finance.yahoo.com/d/quotes.csv?s=" + Cells(i, 1)     i = i + 1     While Cells(i, 1) <> ""         qurl = qurl + "+" + Cells(i, 1)         i = i + 1     Wend     qurl = qurl + "&f=" + Range("C2")     Range("c1") = qurl QueryQuote:              With ActiveSheet.QueryTables.Add(Connection:="URL;" & qurl, Destination:=DataSheet.Range("C7"))                 .BackgroundQuery = True                 .TablesOnlyFromHTML = False                 .Refresh BackgroundQuery:=False                 .SaveData = True             End With                          Range("C7").CurrentRegion.TextToColumns Destination:=Range("C7"), DataType:=xlDelimited, _                 TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _                 Semicolon:=False, Comma:=True, Space:=False, other:=False                              'turn calculation back on     Application.Calculation = xlCalculationAutomatic     Application.DisplayAlerts = True '    Range("C7:H2000").Select '    Selection.Sort Key1:=Range("C8"), Order1:=xlAscending, Header:=xlGuess, _ '        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom     Columns("C:C").ColumnWidth = 12     Columns("J:J").ColumnWidth = 25.43     Range("h2").Select End Sub 

从 Yahoo 下载历史数据 VBA



Sub GetData() '   thanks to Ron McEwan :^)     Dim QuerySheet As Worksheet     Dim DataSheet As Worksheet     Dim EndDate As Date     Dim StartDate As Date     Dim Symbol As String     Dim qurl As String     Dim nQuery As Name         Application.ScreenUpdating = False     Application.DisplayAlerts = False     Application.Calculation = xlCalculationManual         Set DataSheet = ActiveSheet            StartDate = DataSheet.Range("B2").Value         EndDate = DataSheet.Range("B3").Value         Symbol = DataSheet.Range("B4").Value         Range("C7").CurrentRegion.ClearContents          'construct the URL for the query                  qurl = "http://chart.yahoo.com/table.csv?s=" & Symbol         qurl = qurl & "&a=" & Month(StartDate) - 1 & "&b=" & Day(StartDate) & _             "&c=" & Year(StartDate) & "&d=" & Month(EndDate) - 1 & "&e=" & _             Day(EndDate) & "&f=" & Year(EndDate) & "&g=" & Range("E3") & "&q=q&y=0&z=" & _             Symbol & "&x=.csv"         Range("c5") = qurl                    QueryQuote:              With ActiveSheet.QueryTables.Add(Connection:="URL;" & qurl, Destination:=DataSheet.Range("C7"))                 .BackgroundQuery = True                 .TablesOnlyFromHTML = False                 .Refresh BackgroundQuery:=False                 .SaveData = True             End With                          Range("C7").CurrentRegion.TextToColumns Destination:=Range("C7"), DataType:=xlDelimited, _                 TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _                 Semicolon:=False, Comma:=True, Space:=False, other:=False                          Range(Range("C7"), Range("C7").End(xlDown)).NumberFormat = "mmm d/yy"             Range(Range("D7"), Range("G7").End(xlDown)).NumberFormat = "0.00"             Range(Range("H7"), Range("H7").End(xlDown)).NumberFormat = "0,000"             Range(Range("I7"), Range("I7").End(xlDown)).NumberFormat = "0.00"     With ThisWorkbook         For Each nQuery In Names             If IsNumeric(Right(nQuery.Name, 1)) Then                 nQuery.Delete             End If         Next nQuery     End With     'turn calculation back on     Application.Calculation = xlCalculationAutomatic     Application.DisplayAlerts = True     Range("C7:I3000").Select     Selection.Sort Key1:=Range("C8"), Order1:=xlAscending, Header:=xlGuess, _         OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom              'UpdateScale         Range("B4").Select End Sub Sub UpdateScale() Dim ChartVar As chart Dim lMax As Long, lMin As Long On Error GoTo ScalingProblem     'Assigns the values in the Min and Max ranges to variables.     With Sheet1         lMax = .Range("Max").Value         lMin = .Range("Min").Value         'Creates chart object.         Set ChartVar = .ChartObjects("Chart 32").chart                                   With ChartVar.Axes(xlValue, xlPrimary)  'Adjusts the price axis                    .MinimumScale = lMin                    .MaximumScale = lMax                End With                  End With Exit Sub ScalingProblem: RetrievalProblem:     MsgBox "Unable to update chart scale.", vbCritical + vbOKOnly, "Scaling Error" End Sub