Here are two functions I wrote a couple of years ago
(when I was new to VBA) that shoud read in 3 years
(adjustable) worth of Historical Prices from YAHOO on
the symbol and write it out to a *.CSV file (Date,Open,
High,Low,Close,Volume). Be sure to set the location
where you want the file to be written. I think every
thing is here that you need. It will check for stock
splits and dividends (remove if not needed). You will
need a worksheet named 'WebData' and a global string
variable called 'URL_Text'. If anything is missing,
let me know. Watch out for wordwrap.
-pb
'* - - - - - - - - - - -
Function Yahoo_History(CurSym As String) As Boolean
Dim Hstry_Dt(1000) As Date
Dim Hstry_Op(1000) As Single
Dim Hstry_Lo(1000) As Single
Dim Hstry_Hi(1000) As Single
Dim Hstry_Cl(1000) As Single
Dim Hstry_Vo(1000) As Single
Dim CvtAmt As Single
Dim CvtRte As Single
Dim DteLmt As Date
Dim SymDte As Date
Dim FilObj As Object
Dim FilRcd As Integer
Dim FlgErr As Boolean
Dim fso ' File System Object
Dim PagCnt As Integer
Dim PagRcd As Integer
Dim Char01 As Long
Dim Char02 As Long
Dim SymRow As Long
Dim ShrNew As Single
Dim ShrOld As Single
Dim TmpRng As Range
Dim TmpSng As Single
Dim TmpStr As String
Yahoo_History = False
' clear the arrays
For FilRcd = 1 To 1000
Hstry_Dt(FilRcd) = 0: Hstry_Op(FilRcd) = 0: Hstry_Hi(FilRcd)
= 0
Hstry_Lo(FilRcd) = 0: Hstry_Cl(FilRcd) = 0: Hstry_Vo(FilRcd)
= 0
Next FilRcd
CvtAmt = 0
CvtRte = 1#
DteLmt = DateAdd("M", 36 * -1, Date) ' 36 Months / 3 Years
FilRcd = 0
PagCnt = 0
' Load the Web Data
URL_Text = "
http://finance.yahoo.com/q/hp?s=" & Symb_Yah
Yahoo_History_Label_1:
FlgErr = WebData_Get("20", URL_Text)
' read through the page
PagRcd = 0
For Each TmpRng In Worksheets("WebData").Range("A3:A100")
If (Not IsDate(TmpRng.Value)) Then Exit For
' check date
If (TmpRng.Value < DteLmt Or FilRcd > 800) Then Exit For
' non numeric value in column 2?
TmpStr = TmpRng.Offset(0, 1).Value
If (Not IsNumeric(TmpStr)) Then
' check for a SPLIT
Char02 = InStr(1, Trim(TmpStr), "Stock Split")
If (Char02 <> 0) Then
Char01 = InStr(1, TmpStr, ":")
ShrNew = Mid(TmpStr, 1, Char01 - 1)
ShrOld = Mid(TmpStr, Char01 + 1, (Char02 - Char01) -
1)
CvtRte = CvtRte * (ShrOld / ShrNew)
End If
' check for a DIVIDEND
Char02 = InStr(1, Trim(TmpStr), "Dividend")
If (Char02 <> 0) Then
Char01 = InStr(1, TmpStr, "$")
TmpSng = Mid(TmpStr, Char01 + 1, (Char02 - Char01) -
1)
CvtAmt = CvtAmt + TmpSng
End If
Else
FilRcd = FilRcd + 1
' check if this is new data
If (FilRcd = 1) Then
SymRow = Get_Symbol_Row(Symb_Wks)
If (TmpRng.Value = Sheets("Symbols").Range("D" &
SymRow)) Then
Exit Function
End If
End If
' load the arrays
Hstry_Dt(FilRcd) = TmpRng.Value
Hstry_Op(FilRcd) = (TmpRng.Offset(0, 1).Value - CvtAmt) *
CvtRte
Hstry_Hi(FilRcd) = (TmpRng.Offset(0, 2).Value - CvtAmt) *
CvtRte
Hstry_Lo(FilRcd) = (TmpRng.Offset(0, 3).Value - CvtAmt) *
CvtRte
Hstry_Cl(FilRcd) = (TmpRng.Offset(0, 4).Value - CvtAmt) *
CvtRte
Hstry_Vo(FilRcd) = TmpRng.Offset(0, 5).Value
Yahoo_History = True
PagRcd = PagRcd + 1
End If
Next
' end of the data?
If (PagRcd >= 66) Then
PagCnt = PagCnt + 1
URL_Text = "
http://finance.yahoo.com/q/hp?s=" & Symb_Yah & _
"&d=" & Mid(Str(Month(Now) - 1), 2) & _
"&e=" & Mid(Str(Day(Now)), 2) & _
"&f=" & Mid(Str(Year(Now)), 2) & _
"&g=d&z=66&y=" & Mid(Str(PagCnt * 66), 2)
GoTo Yahoo_History_Label_1
End If
' Write History?
If (FilRcd > 0) Then
TmpStr = "C:\History\" & Symb_Ash & ".csv"
Set fso = CreateObject("Scripting.FileSystemObject")
Set FilObj = fso.CreateTextFile(TmpStr)
PagRcd = FilRcd
Do While (PagRcd > 0)
' change the date from: MM/DD/YYYY --> YYYY/MM/DD
TmpStr = Cvt_Date(Hstry_Dt(PagRcd))
TmpStr = TmpStr & "," & Trim(CStr(Hstry_Op(PagRcd)))
TmpStr = TmpStr & "," & Trim(CStr(Hstry_Hi(PagRcd)))
TmpStr = TmpStr & "," & Trim(CStr(Hstry_Lo(PagRcd)))
TmpStr = TmpStr & "," & Trim(CStr(Hstry_Cl(PagRcd)))
TmpStr = TmpStr & "," & Trim(CStr(Hstry_Vo(PagRcd)))
FilObj.WriteLine TmpStr
PagRcd = PagRcd - 1
Loop
FilObj.Close
Set fso = Nothing
End If
End Function
'* - - - - - - - - - - -
Function WebData_Get(WEB_tbl As String, WEB_url As String) As Boolean
' clear the worksheet
Sheets("WebData").Select
Rows("3:1000").Select
Selection.Delete Shift:=xlUp
Columns("B:AG").Select
Selection.Delete Shift:=xlToLeft
' Load the Web Data
Sheets("WebData").Select
Workbooks(ActiveWorkbook.Name).Sheets("WebData").Range("A1") = ">"
& WEB_url
Range("A2").Select
ActiveCell.Value = ""
WebData_Get = False
If (WEB_tbl = "") Then GoTo WebData_Get_Page
WebData_Get_Table:
On Error GoTo WebData_Get_Error
With Selection.QueryTable
.Name = "WebData"
.Connection = "URL;" & WEB_url
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingNone
.WebTables = WEB_tbl
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
GoTo WebData_Get_End
WebData_Get_Page:
On Error GoTo WebData_Get_Error
With Selection.QueryTable
.Name = "WebData"
.Connection = "URL;" & WEB_url
.WebSelectionType = xlEntirePage
.WebFormatting = xlWebFormattingNone
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
GoTo WebData_Get_End
WebData_Get_Error:
WebData_Get = True
WebData_Get_End:
On Error GoTo 0
WEB_tbl = ""
WEB_url = ""
End Function
'* - - - - - - - - - - -
