This is a walk through on how to automate the downloading and storing of Yahoo Finance Historical prices and analyst reports.

Due to a character limit Ill post the rest in the comments... SORRY!

---------DOWNLOAD YAHOO-------------------------------------------------------------------
Sub yahoo_data()

Dim IE As Object
Dim Downloadstring As String
Dim Val1 As String
Dim val2 As String
Dim list1 As String

On Error GoTo err:

For Q = 0 To UserForm1.ListBox1.ListCount - 1 ' Go through list of stock tickers from listbox
Val1 = UserForm1.ListBox1.List(Q) ' stock ticker value
UserForm1.Label4.Width = (UserForm1.Frame3.Width / 6) * 1 'update userform process
DoEvents 'update userform process
UserForm1.Label3.Caption = Q + 1 & " of " & UserForm1.ListBox1.ListCount & " Download Complete" 'update userform process
DoEvents

Dim dtPrevDate As Date
Dim strURL As String, strCSV As String, strRows() As String, strColumns() As String
Dim dbClose As Double

UserForm1.Label4.Width = (UserForm1.Frame3.Width / 6) * 2 'update userform process
DoEvents 'update userform process
Downloadstring = "[ Ссылка ]=" & Val1 ' Download STING!!!!!!!
UserForm1.Label4.Width = (UserForm1.Frame3.Width / 6) * 3 'update userform process
DoEvents
' Debug.Print strURL

Dim filename1 As String
filename1 = special_Characters(Val1)
UserForm1.Label4.Width = (UserForm1.Frame3.Width / 6) * 4 'update userform process
DoEvents
UserForm1.Label4.Width = (UserForm1.Frame3.Width / 6) * 5 'update userform process
DoEvents
Call Download_This_File_Please(Downloadstring, filename1) ' CALLING DOWNLOAD Macro
UserForm1.Label4.Width = (UserForm1.Frame3.Width / 6) * 6 'update userform process
DoEvents


Next Q

err:
Debug.Print err.Number
Debug.Print err.Description
Select Case err.Number
End Select
End Sub

Sub Download_This_File_Please(Downloadstring As String, filename1 As String)
Dim WinHttpReq As Object
Set WinHttpReq = CreateObject("Microsoft.XMLHTTP")
WinHttpReq.Open "GET", Downloadstring, False, "", ""
WinHttpReq.send

myURL = WinHttpReq.responseBody
If WinHttpReq.Status = 200 Then
Set oStream = CreateObject("ADODB.Stream")
oStream.Open
oStream.Type = 1
oStream.write WinHttpReq.responseBody
Savepath1 = UserForm1.TextBox2.Text & "backslash" ‘’’’’ replace with backslash
oStream.SaveToFile Savepath1 & filename1 & ".csv", 2 ' 1 = no overwrite, 2 = overwrite
oStream.Close
End If
End Sub

Function Special_Characters(name1 As String)
Dim special_char() As String
Dim SP As String
SP = "!,@,#,$,%,^,&,*,(,),+,\,?,/,_,-,.,"
special_char = Split(SP, ",")
For i = 0 To UBound(special_char)
name1 = Replace(name1, special_char(i), "")
Next i
Special_Characters = name1
End Function
------------------------------------------------------------------------------------------------------------

свернуть