[ ramzesIV @ 28.07.2011. 13:53 ] @
Code: Sub GetOne() ' Download one stock only 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.DisplayAlerts = False Application.Calculation = xlCalculationAutomatic 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("C4") & "&q=q&y=0&z=" & _ Symbol & "&x=.csv" 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("C1:I1").Select Selection.ColumnWidth = 8 'turn calculation back on Application.DisplayAlerts = True Range("C8:I6000").Select Selection.Sort Key1:=Range("C8"), Order1:=xlAscending, Header:=xlGuess, _ OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom RemoveNames Range("A1").Select End Sub Sub RemoveNames() Dim nQuery As Name For Each nQuery In Names If IsNumeric(Right(nQuery.Name, 1)) Then nQuery.Delete End If Next nQuery End Sub resila sam problem. ako nekom treba kod da downloaduje podatke u excel, ovo je po meni jedan od boljih makroa. [Ovu poruku je menjao ramzesIV dana 29.07.2011. u 11:20 GMT+1] [Ovu poruku je menjao ramzesIV dana 29.07.2011. u 11:21 GMT+1] |