Yahoo has changed their url . See code example below
Sub GetData()
Dim QuerySheet As Worksheet
Dim DataSheet As Worksheet
Dim qurl As String
Dim i As Integer, iMax As Integer
Dim Sym As String
Clear
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
Set DataSheet = ActiveSheet
For iMax = 0 To 20000 Step 100
i = 7 + iMax
If Cells(i, 1) = "" Then
GoTo stopHere
End If
qurl = "http://download.finance.yahoo.com/d/quotes.csv?s=" + Cells(i, 1)
i = i + 1
While Cells(i, 1) <> "" And i < iMax + 107
Sym = Cells(i, 1)
'Sym = Replace(Sym, ".", "-")
'Sym = Replace(Sym, "-TO", ".TO") 'TORONTO
'Sym = Replace(Sym, "-PK", ".PK") 'PINK
'Sym = Replace(Sym, "-OB", ".OB") 'BB
qurl = qurl + "+" + Sym
i = i + 1
Wend
qurl = qurl + "&f=" + Range("C2")
Range("c1") = qurl
QueryQuote:
With ActiveSheet.QueryTables.Add(Connection:="URL;" & qurl, Destination:=DataSheet.Range("N7"))
.BackgroundQuery = True
.TablesOnlyFromHTML = False
.Refresh BackgroundQuery:=False
.SaveData = True
End With
Range("N7:N107").Select
Selection.TextToColumns Destination:=Range("N7"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=True, Space:=False, Other:=False
' FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
' Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1))
Range("N7:W107").Select
Selection.Copy
Cells(7 + iMax, 3).Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Range("N7:W107").Select
Selection.ClearContents
Next iMax
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
stopHere:
Clear2
End Sub
Sub Clear()
'
' Clear Macro
' Macro recorded 23/01/2008 by pjPonzo
'
'
Range("C7:L1200").Select
Selection.ClearContents
End Sub
Sub Clear2()
'
' clear2 Macro
' Macro recorded 25/03/2008 by pjPonzo
'
'
Columns("N:AA").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
Range("A1").Select
End Sub
Sub doALL()
Sheets("Yahoo1").Select
GetData
Sheets("Yahoo2").Select
GetData
Sheets("Yahoo3").Select
GetData
End Sub
__._,_.___
Posted by: logitga@yahoo.com
| Reply via web post | • | Reply to sender | • | Reply to group | • | Start a New Topic | • | Messages in this topic (2) |
Have you tried the highest rated email app?
With 4.5 stars in iTunes, the Yahoo Mail app is the highest rated email app on the market. What are you waiting for? Now you can access all your inboxes (Gmail, Outlook, AOL and more) in one place. Never delete an email again with 1000GB of free cloud storage.
----------------------------------
Be sure to check out TechTrax Ezine for many, free Excel VBA articles! Go here: http://www.mousetrax.com/techtrax to enter the ezine, then search the ARCHIVES for EXCEL VBA.
----------------------------------
Visit our ExcelVBA group home page for more info and support files:
http://groups.yahoo.com/group/ExcelVBA
----------------------------------
More free tutorials and resources available at:
http://www.mousetrax.com
----------------------------------
Be sure to check out TechTrax Ezine for many, free Excel VBA articles! Go here: http://www.mousetrax.com/techtrax to enter the ezine, then search the ARCHIVES for EXCEL VBA.
----------------------------------
Visit our ExcelVBA group home page for more info and support files:
http://groups.yahoo.com/group/ExcelVBA
----------------------------------
More free tutorials and resources available at:
http://www.mousetrax.com
----------------------------------
.
__,_._,___
Tidak ada komentar:
Posting Komentar