Option Explicit
Public Sub Test()
Sheets("Sheet1").Range("A1:A3").Value = WorksheetFunction.Transpose(Array("AAPL", "MSFT", "INTC"))
Get_Yahoo_Finance_Data
End Sub
Public Sub Get_Yahoo_Finance_Data()
Dim baseURL As String, URL As String
Dim dataSheet As Worksheet, querySheet As Worksheet
Dim QT As QueryTable
Dim lastRow As Long
Dim symbol As Range
baseURL = "http://finance.yahoo.com/q/pr" '?s=AAPL+Profile
'Sheet containing symbols to be retrieved
Set dataSheet = Worksheets("Sheet1")
'Sheet containing existing web query or where a new query will be created
Set querySheet = Worksheets("Sheet3")
'Create new web query or using existing one
If querySheet.QueryTables.Count = 0 Then
Set QT = Create_WebQuery(querySheet)
Else
Set QT = querySheet.QueryTables(1)
End If
If Not QT Is Nothing Then
'Request data for each symbol in column A starting at row 1
With dataSheet
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For Each symbol In .Range("A1:A" & lastRow)
URL = baseURL & "?s=" & symbol.Value & "+Profile"
symbol.Offset(0, 1).Value = ""
Get_Business_Summary QT, URL, symbol.Offset(0, 1)
DoEvents
Next
End With
Else
MsgBox "Web query not created"
End If
End Sub
Private Sub Get_Business_Summary(QT As QueryTable, sURL As String, destRange As Range)
Dim savedErr As ErrObject
Dim findCell As Range
On Error Resume Next 'Trap possible errors from refreshing web query
QT.Connection = "URL;" & sURL
QT.Refresh BackgroundQuery:=False
If Err.Number = 0 Then
'No error occurred - find the cell containing 'Business Summary' and copy data from 2 cells below it to destination range
On Error GoTo 0
Debug.Print Now; sURL & " - Retrieved OK"
Set findCell = QT.Parent.Cells.Find(What:="Business Summary", After:=QT.Parent.Range("A1"), _
LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True, SearchFormat:=False)
If Not findCell Is Nothing Then
findCell.Offset(2, 0).Copy destRange
Else
MsgBox "Business Summary not found for " & vbCr & sURL
End If
Else
'An unexpected error occurred - tell the user
Set savedErr = Err
On Error GoTo 0
Debug.Print Now; sURL & " - Error " & savedErr.Number & " " & savedErr.Description
MsgBox "Weq query URL: " & sURL & vbCr & _
"Error number " & savedErr.Number & vbCr & _
savedErr.Description, , "Web query error"
End If
End Sub
Private Function Create_WebQuery(querySheet As Worksheet) As QueryTable
'Create web query on specified sheet. Note that a URL is not specified in the Connection string, but instead is specified when querying each symbol
Set Create_WebQuery = querySheet.QueryTables.Add(Connection:="URL;", Destination:=querySheet.Range("A1"))
If Not Create_WebQuery Is Nothing Then
With Create_WebQuery
.Name = "Yahoo_Finance"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlEntirePage 'Import entire page
.WebFormatting = xlWebFormattingNone
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
'.Refresh BackgroundQuery:=False 'Refresh when retrieving each URL, not here
End With
End If
End Function
