*This is for Excel's VBA
This is probably just a stupid logic error on my part but I've been working on this for hours and I just can't seem to figure it out:
I have a webpage with two links I need to access. These two links are changing daily, but always have the same beginning sequence (Example.... Google websites almost always begin with "http://www.google.com")
I have the code to search through all "a" HTML tags for links that have certain text in them (like "google"). If the link is found, I need to click the link, then go back (via objIE.Back) and continue the loop sequence without resetting. It is this last part that I am having trouble with. My code grabs the first link it see's, does what I want it to do, goes back, but then it doesn't seem to remember that it already handled the first link and it just keeps repeating the finding of that first link.
Can anyone take a look at what I have and tell me where I went wrong?
Edit: I have updated this with my current code with the stupid loop and "End For" deleted. Same thing is happening though. Where did I go wrong?
Sub Button17_Click()
Dim objIE As SHDocVw.InternetExplorer
Dim OrgBox As HTMLInputElement
Dim ticketnumber As String
Dim Error As String
Dim subaccnum As String
Dim IEURL As String
Dim button As Object
Dim ele As Object
Dim NodeList As Object
Dim tagName As Object
Dim elementid As Object
Dim Tag As Object
Dim hrefvalue As String
Dim hrefurlvalue As String
Dim trimedhrefvalue As String
Dim ieLinks As Object
Dim Links As Object
Dim ieAnchors As Object
Dim Anchor As Object
Dim I As Integer
Sheets("Sheet1").Activate
Range("A5").Value = ""
Range("A9").Value = ""
subaccnum = Range("A2").Value
On Error Resume Next
Application.StatusBar = "Opening Internet Explorer"
Set objIE = New InternetExplorerMedium
objIE.navigate "http://www.youtube.com" ' This is just a test website as my website is under a private VPN and cannot be accessed by anyone but me. Website should not effect loop though
objIE.Visible = True 'False
Application.StatusBar = "Loading website..."
Do While objIE.readyState < 4: Loop
Set objIE2 = Nothing
'Call Wait
Application.Wait (Now + TimeValue("0:00:3"))
Application.StatusBar = "Trying to find link..."
Application.Wait (Now() + TimeValue("00:00:05"))
'objIE.document.parentWindow.execScript "execute('RefreshList');"
Set ieLinks = objIE.document.getElementsByTagName("a")
For Each Links In ieLinks
If Links.outerHTML Like "<A href=""javascript:fnOpenWindow('/ao/party/popuppartyinfo?partyId=*" Then
'Links.Click
Application.StatusBar = "Found link! Please wait"
Links.Value = hrefvalue
trimedhrefvalue = Right(Links, 49)
hrefurlvalue = "http://www.youtube.com" & trimedhrefvalue
objIE.navigate hrefurlvalue
Do While objIE.readyState < 4: Loop
'Call Wait
Application.Wait (Now + TimeValue("0:00:5"))
Application.ScreenUpdating = True
Application.StatusBar = "Extracting Email From Server..."
IEURL = objIE.LocationURL
'Range("A12").Value = IEURL
ThisWorkbook.Sheets("Import").Activate
Rows("1:500").Delete
With ActiveSheet.QueryTables.Add(Connection:= _
"URL;" & IEURL, _
Destination:=Range("a2"))
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = False
.RefreshOnFileOpen = False
.BackgroundQuery = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlEntirePage
.WebFormatting = xlWebFormattingAll
.WebPreFormattedTextToColumns = False
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
Application.ScreenUpdating = True
Application.StatusBar = "Adding Data to spreadsheet..."
Cells.Find(What:="Email Address", After:=Range("A1"), LookIn:=xlFormulas, Lookat:= _
xlWhole, searchorder:=xlByRows, searchdirection:=xlNext, MatchCase:=False _
, SearchFormat:=False).Activate
ActiveCell.Offset(RowOffset:=0, columnOffset:=1).Activate
Selection.Copy
Sheets("Sheet1").Select
Range("A" & Rows.Count).End(xlUp).Offset(1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Import").Select
If ActiveCell.Offset(RowOffset = 1).Value <> "" Then
ActiveCell.Offset(RowOffset = 1).Copy
Sheets("Sheet1").Select
ActiveCell.Offset(RowOffset = 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End If
Application.ScreenUpdating = True
objIE.GoBack
Do While objIE.readyState < 4: Loop
'Call Wait
Application.Wait (Now + TimeValue("0:00:4"))
Application.StatusBar = "Searching for 2nd account owner..."
End If
Next Links
End Sub
Possible workaround:
For i = 1 To ieLinks.Length
If ieLinks.Item(i).outerHTML Like "<A href=""javascript:fnOpenWindow('/ao/party/popuppartyinfo?partyId=*" Then
'Links.Click
Application.StatusBar = "Found link! Please wait"
ieLinks.Item(i).Value = hrefvalue
trimedhrefvalue = Right(ieLinks.Item(i), 49)
hrefurlvalue = "http://www.youtube.com" & trimedhrefvalue
objIE.navigate hrefurlvalue
.....................
Next i
EDIT: TEMPORARY SOLUTION FOUND
In the end, I never did get that link to work. What I did was that I assigned the ieLinks.Item(i) to a random range on the spreadsheet (somewhere nobody will ever scroll to). Once the links are here, they remain static. Then I just made a simple "For each Cell in rng" loop to run through each link until the end.
This is not what I originally set out to do, nor is it an exact answer to this question, but it is a temporary solution that makes the modification of the links much easier than keeping the links in VBA's memory.
Get rid of the "Exit For" line and it should go to the next one.
You haven't included all of the code, as this all seems to appear within some other loop (judging by the "Loop" statement at the bottom that doesn't have a matching "Do WHile" or other loop structure. You may be looping forever depending on what is happening in that loop.
******EDIT****
The second problem I see is in this part of the code:
If Links.outerHTML Like "<A href=""javascript:fnOpenWindow('/ao/party/popuppartyinfo?partyId=*" Then
Application.StatusBar = "Found link! Please wait"
Links.Value = hrefvalue
trimedhrefvalue = Right(Links, 49)
hrefurlvalue = "http://www.youtube.com" & trimedhrefvalue
objIE.navigate hrefurlvalue
......
Here, you are setting "Links.Value" to hrefvalue, which hasn't been initialized, so it is an empty string. When trying to test this, it wouldn't even let me change this value and threw an error, but assuming that it does, you are setting the value to "", then getting the right 49 characters of it and appending it to the website. This would seem to keep opening the same website....
Related
There is a website, that can create thousands of .csv files that contain tables. The CSV files are based on the information the user asks.
I created an excel file with VBA script. The user enters the data to the excel file, then the VBA script generates the correct URL, and tries to get the required data from the .csv in that URL.
In my excel file, the user can ask for hundreds of .csv tables, and I want the user to be able to enter the hundreds of information kinds he wants, then run the VBA script and leave the computer to work on it.
I first do URL check, and if it is ok, I try to get the data in the .csv file in that URL.
most of the times, it works completely fine. Works fine for a case when HttpExists returns TRUE, and also works fine for a case that HttpExists returns FALSE (it just skips the current active cell and goes to the next one).
But there are a few times, that the URL check answers that the URL is fine (HttpExists returns TRUE), but when it tried to get the data, it opens a message box that says "sorry, we couldn't open 'url address' ". (message box for Run Time Error 1004) and then the VBA scripts terminates.
I would like to know how can I fix it. How can I just skip the current URL in case of error, instead of showing a message box that terminates the script run?
Sub my_method()
On Error GoTo handleCancel
Dim errorFlag As Boolean
.......
Do Until ActiveCell.Value = ""
errorFlag = True
URLstring= ....
........
If Not HttpExists(URLstring) Then
symbolStatus = "Data unavailable"
logAddress = updateLog("invalid URL " & ActiveCell.Value, logAddress, debugString)
Application.DisplayAlerts = False
Sheets(currentSymbol).Delete
Application.DisplayAlerts = True
Else
With Sheets(currentSymbol).QueryTables.Add(Connection:= _
"TEXT;" & URLstring _
, Destination:=Sheets(currentSymbol).Range(dataAddress))
.Name = ""
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlOverwriteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 850
.TextFileStartRow = 2
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = True
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(2, 2, 2, 2, 2, 2, 9)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
.......
errorFlag = False
handleCancel:
ActiveCell.Offset(1, 0).Select
If errorFlag = True Then
symbolStatus = "Data unavailable"
logAddress = updateLog("invalid URL " & ActiveCell.Value,
logAddress, debugString)
Application.DisplayAlerts = False
Sheets(currentSymbol).Delete
Application.DisplayAlerts = True
End If
Loop
End Sub
Function HttpExists(sURL As String) As Boolean
Dim oXHTTP As Object
Set oXHTTP = CreateObject("MSXML2.ServerXMLHTTP")
If Not UCase(sURL) Like "HTTP:*" Then
sURL = "http://" & sURL
End If
On Error GoTo haveError
oXHTTP.Open "HEAD", sURL, False
oXHTTP.send
HttpExists = IIf(oXHTTP.status = 200, True, False)
Exit Function
haveError:
HttpExists = False
End Function
It sometimes goes out with a messagebox of Run Time Error 1004, and it happens in the line of:
With Sheets(currentSymbol).QueryTables.Add(Connection:= _
"TEXT;" & URL _
I would like it just to skip the current cell in a case of error, and go on with the next cell, without any messagebox and without crashing.
How can I fix it?
Thanks
See if this error handling structure works better. I eliminated parts that are unnecessary and adjusted to what should work, but I am not sure what code is in the ..... sections. Anyway, this should at least give you a general understanding. I commented a few things to explain more clearly in code.
Option Explicit
Sub my_method()
Do Until ActiveCell.Value = ""
'URLstring= ....
If Not HttpExists(URLstring) Then
LogError 'create sub since you do same thing twice
Else
On Error GoTo handleBadURL 'now is only time you need to move to actual error handling
With Sheets(currentSymbol).QueryTables.Add(Connection:= _
"TEXT;" & URLstring _
, Destination:=Sheets(currentSymbol).Range(dataAddress))
.Name = ""
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlOverwriteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 850
.TextFileStartRow = 2
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = True
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(2, 2, 2, 2, 2, 2, 9)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
On Error Go To 0 'reset error handling (doesn't matter so much here, but good practice to always reset when not needed
End If
ActiveCell.Offset(1, 0).Select
Loop
Exit Sub 'leave sub when all is done (so it doesn't move to error handling code below
handleBadURL:
LogError 'created sub since you do same thing twice
Resume Next 'this statement will allow code to continue from point of error onward (the loop will keep going
End Sub
Sub LogError()
symbolStatus = "Data unavailable"
logAddress = updateLog("invalid URL " & ActiveCell.Value, logAddress, debugString)
Application.DisplayAlerts = False
Sheets(currentSymbol).Delete
Application.DisplayAlerts = True
End Sub
You need to add error handling to your code. Server timeout notices doesn't reflect an issue with your coding, but an issue with the server (which is out of your control, unless of course, you entered an incorrect URL).
In your code, you need to place On Error GoTo ErrHandler, make sure you have the error number, and since you are wanting to just resume to the next cell you can do something like this:
Sub Test()
On Error GoTo ErrHandler
'Your code
Exit Sub
ErrHandler:
If Err.Number = 123456 Then
'Get the code ready for the next cell, if necessary
Resume Next
Else
'Other Errs
End If
End Sub
I wrote a Web Query macro to import financial statements from Yahoo Finance based on the value in cell A1. It was working seamlessly for the past few weeks, but suddenly, it no longer returns any data (but does not generate an error). If anyone has any insights, I would appreciate your guidance. I have posted the code below--thank you!
Sub ThreeFinancialStatements()
On Error GoTo Explanation
Rows("2:1000").Select
Selection.ClearContents
Columns("B:AAT").Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.ClearContents
Dim inTicker As String
inTicker = Range("A1")
ActiveSheet.Name = UCase(inTicker)
GetFinStats inTicker
Exit Sub
Explanation:
MsgBox "Please make sure you type a valid stock ticker symbol into cell A1 and are not trying to create a duplicate sheet." & _
vbLf & " " & _
vbLf & "Also, for companies with different classes of shares (e.g. Berkshire Hathaway), use a hyphen to designate the ticker symbol instead of a period (e.g. BRK-A)." & _
vbLf & " " & _
vbLf & "Please also note that not every company has three years of financial statements, so data may appear incomplete or missing for some companies.", _
, "Error"
Exit Sub
End Sub
Sub GetFinStats(inTicker As String)
'
' GetBalSheet Macro
'
'
With ActiveSheet.QueryTables.Add(Connection:= _
"URL;http://finance.yahoo.com/q/bs?s=" & inTicker & "+Balance+Sheet&annual", Destination:= _
Range("$D$1"))
.Name = "bs?s=PEP+Balance+Sheet&annual"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlOverwriteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingNone
.WebTables = "9"
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
With ActiveSheet.QueryTables.Add(Connection:= _
"URL;http://finance.yahoo.com/q/is?s=" & inTicker & "+Income+Statement&annual", Destination _
:=Range("$J$1"))
.Name = "is?s=PEP+Income+Statement&annual"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlOverwriteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingNone
.WebTables = "9"
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
With ActiveSheet.QueryTables.Add(Connection:= _
"URL;http://finance.yahoo.com/q/cf?s=" & inTicker & "+Cash+Flow&annual", Destination:= _
Range("$P$1"))
.Name = "cf?s=PEP+Cash+Flow&annual"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlOverwriteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingNone
.WebTables = "9"
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
Range("A3").Select
ActiveCell.FormulaR1C1 = "Current Ratio"
Range("A4").Select
ActiveCell.FormulaR1C1 = "Quick Ratio"
Range("A5").Select
ActiveCell.FormulaR1C1 = "Cash Ratio"
Range("A6").Select
Range("A7").Select
ActiveCell.FormulaR1C1 = "Revenue Growth Rate"
Range("A9").Select
Columns("A:A").ColumnWidth = 21.86
ActiveCell.FormulaR1C1 = "ROA"
Range("A10").Select
ActiveCell.FormulaR1C1 = "ROE"
Range("A11").Select
ActiveCell.FormulaR1C1 = "ROIC"
Range("B3").Select
ActiveCell.Formula = "=F11/F28"
Range("B4").Select
ActiveCell.Formula = "=(F11-F8)/F28"
Range("B5").Select
ActiveCell.Formula = "=F5/F28"
Range("B7").Select
ActiveCell.Formula = "=(L2/N2)^(1/2)-1"
Range("B9").Select
ActiveCell.Formula = "=L35/SUM(F12:F18)"
Range("B10").Select
ActiveCell.Formula = "=L35/F47"
Range("B11").Select
ActiveCell.Formula = "=L35/(F47+SUM(F29:F33))"
Range("B3").Select
Selection.NumberFormat = "0.00"
Range("B4").Select
Selection.NumberFormat = "0.00"
Range("B5").Select
Selection.NumberFormat = "0.00"
Range("B7").Select
Selection.NumberFormat = "0.00%"
Range("B9").Select
Selection.NumberFormat = "0.00%"
Range("B10").Select
Selection.NumberFormat = "0.00%"
Range("B11").Select
Selection.NumberFormat = "0.00%"
Range("A1").Select
End Sub
Your code is obviously working against a specific worksheet:
Rows("2:1000").Select
But what sheet is that? Only you can know that.
As written, it's whatever the active worksheet is, regardless of how much sense that makes.
Unqualified, these functions all implicitly refer to the ActiveSheet:
Range
Cells
Columns
Rows
Names
So you need to qualify them. And you do that by specifying a specific Worksheet object they should be working with - suppose that's DataSheet (I've no idea):
DataSheet.Rows("2:1000").Select
That would .Select the specified rows on the worksheet pointed to by the DataSheet object.
By why do you need to .Select it? This:
Rows("2:1000").Select
Selection.ClearContents
Could just as well be:
DataSheet.Rows("2:1000").ClearContents
Or better - assuming your data is formatted as a table (seems it looks like one anyway - so why not use the ListObjects API?):
DataSheet.ListObjects("DataTable").DataBodyRange.Delete
Sounds like that instruction has just replaced all the .Select and .ClearContents going on here. Note that .Select mimicks user action - the user clicking on a cell (or anything really) and selecting it. You have programmatic access to the entire object model - you never need to .Select anything!
Dim inTicker As String
inTicker = Range("A1")
Here you're implicitly reading from the active sheet, but you're also implicitly converting a Variant (the cell's value) into a String, which may or may not succeed. If A1 contains an error value (e.g. #REF!), the instruction fails.
With DataSheet.Range("A1")
If Not IsError(.Value) Then
inTicker = CStr(.Value)
Else
'decide what to do then
End If
End With
Your error-handling subroutine should at least Debug.Print Err.Number, Err.Description so that you have a bit of a clue about why things blew up. Right now it's assuming a reason for failure, and as you saw, Excel is full of traps.
Also you're using vbLf, but that's only half of a proper Windows newline character. Use vbNewLine if you're not sure what that is.
An Exit Sub instruction just before an End Sub token is completely useless.
Sub GetFinStats(inTicker As String)
The procedure is implicitly Public, and inTicker is implicitly passed ByRef. Kudos for giving it an explicit type!
This would be better:
Private Sub GetFinStats(ByVal inTicker As String)
With ActiveSheet.QueryTables
At least that's explicit about using the active sheet. But should it use the active sheet, or a specific sheet? And what happens to the query tables that were already there?
I strongly recommend you type this in the immediate pane:
?ThisWorkbook.Connections.Count
If the number is greater than the number of .QueryTables.Add calls you have in your procedure (likely), you have quite a problem there: I suspect you have over a hundred connections in the workbook, and clicking the "Refresh All" button takes forever to finish, and it's fairly possible that finance.yahoo.com is receiving dozens of requests from a single IP in a very limited amount of time, and refuses to serve them.
Delete all unused workbook connections. And then fix the implicit ActiveSheet references there too, and get rid of all these useless .Select calls:
With TheSpecificSheet
With .QueryTables.Add( ... )
End With
With .QueryTables.Add( ... )
End With
With .QueryTables.Add( ... )
End With
'assgin .Value, not .FormulaR1C1; you're not entering a R1C1 formula anyway
.Range("A3").Value = "Current Ratio"
.Range("A4").Value = "Quick Ratio"
.Range("A5").Value = "Cash Ratio"
End With
Consecutive .Select calls mean all but the last one serve a purpose, if any:
Range("A6").Select
Range("A7").Select
Again, don't assign ActiveCell when you can assign .Range("A7").Value directly.
And you can set number formats for a range of cells:
.Range("B3:B11").NumberFormat = "0.00%"
You can still retrieve the necessary data by parsing JSON response either from
https://finance.yahoo.com/quote/AAPL/financials(extracting data from HTML content, AAPL here just for example)
or via API
https://query1.finance.yahoo.com/v10/finance/quoteSummary/AAPL?lang=en-US®ion=US&modules=incomeStatementHistory%2CcashflowStatementHistory%2CbalanceSheetHistory%2CincomeStatementHistoryQuarterly%2CcashflowStatementHistoryQuarterly%2CbalanceSheetHistoryQuarterly%2Cearnings
You may use the below VBA code to parse response and output result. Import JSON.bas module into the VBA project for JSON processing. Here are Sub Test_query1_finance_yahoo_com() to get data via API and Test_finance_yahoo_com_quote to extract data from HTML content:
Option Explicit
Sub Test_query1_finance_yahoo_com()
Dim sSymbol As String
Dim sJSONString As String
Dim vJSON As Variant
Dim sState As String
sSymbol = "AAPL"
' Get JSON via API
With CreateObject("MSXML2.XMLHTTP")
.Open "GET", "https://query1.finance.yahoo.com/v10/finance/quoteSummary/" & sSymbol & "?lang=en-US®ion=US&modules=incomeStatementHistory%2CcashflowStatementHistory%2CbalanceSheetHistory%2CincomeStatementHistoryQuarterly%2CcashflowStatementHistoryQuarterly%2CbalanceSheetHistoryQuarterly%2Cearnings", False
.Send
sJSONString = .ResponseText
End With
' Parse JSON response
JSON.Parse sJSONString, vJSON, sState
If sState = "Error" Then
MsgBox "Invalid JSON"
Exit Sub
End If
' Pick core data
Set vJSON = vJSON("quoteSummary")("result")(0)
' Output
QuoteDataOutput vJSON
MsgBox "Completed"
End Sub
Sub Test_finance_yahoo_com_quote()
Dim sSymbol As String
Dim sJSONString As String
Dim vJSON As Variant
Dim sState As String
sSymbol = "AAPL"
' Get webpage HTML response
With CreateObject("Msxml2.XMLHTTP")
.Open "GET", "https://finance.yahoo.com/quote/" & sSymbol & "/financials", False
.Send
sJSONString = .ResponseText
End With
' Extract JSON from HTML content
sJSONString = "{" & Split(sJSONString, "root.App.main = {")(1)
sJSONString = Split(sJSONString, "}(this));")(0)
sJSONString = Left(sJSONString, InStrRev(sJSONString, "}"))
' Parse JSON response
JSON.Parse sJSONString, vJSON, sState
If sState = "Error" Then
MsgBox "Invalid JSON"
Exit Sub
End If
' Pick core data
Set vJSON = vJSON("context")("dispatcher")("stores")("QuoteSummaryStore")
' Output
QuoteDataOutput vJSON
MsgBox "Completed"
End Sub
Sub QuoteDataOutput(vJSON)
Const Transposed = True ' Output option
Dim oItems As Object
Dim vItem
Dim aRows()
Dim aHeader()
' Fetch main structures available from JSON object to dictionary
Set oItems = CreateObject("Scripting.Dictionary")
With oItems
.Add "IncomeStatementY", vJSON("incomeStatementHistory")("incomeStatementHistory")
.Add "IncomeStatementQ", vJSON("incomeStatementHistoryQuarterly")("incomeStatementHistory")
.Add "CashflowY", vJSON("cashflowStatementHistory")("cashflowStatements")
.Add "CashflowQ", vJSON("cashflowStatementHistoryQuarterly")("cashflowStatements")
.Add "BalanceSheetY", vJSON("balanceSheetHistory")("balanceSheetStatements")
.Add "BalanceSheetQ", vJSON("balanceSheetHistoryQuarterly")("balanceSheetStatements")
.Add "EarningsChartQ", vJSON("earnings")("earningsChart")("quarterly")
.Add "FinancialsChartY", vJSON("earnings")("financialsChart")("yearly")
.Add "FinancialsChartQ", vJSON("earnings")("financialsChart")("quarterly")
End With
' Output each data set to separate worksheet
For Each vItem In oItems
' Convert each data set to array
JSON.ToArray oItems(vItem), aRows, aHeader
' Output array to worksheet
With GetSheet((vItem))
.Cells.Delete
If Transposed Then
Output2DArray .Cells(1, 1), WorksheetFunction.Transpose(aHeader)
Output2DArray .Cells(1, 2), WorksheetFunction.Transpose(aRows)
Else
OutputArray .Cells(1, 1), aHeader
Output2DArray .Cells(2, 1), aRows
End If
.Columns.AutoFit
End With
Next
End Sub
Function GetSheet(sName As String, Optional bCreate = True) As Worksheet
On Error Resume Next
Set GetSheet = ThisWorkbook.Sheets(sName)
If Err Then
If bCreate Then
Set GetSheet = ThisWorkbook.Sheets.Add(, ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
GetSheet.Name = sName
End If
Err.Clear
End If
End Function
Sub OutputArray(oDstRng As Range, aCells As Variant)
With oDstRng
.Parent.Select
With .Resize(1, UBound(aCells) - LBound(aCells) + 1)
.NumberFormat = "#"
.Value = aCells
End With
End With
End Sub
Sub Output2DArray(oDstRng As Range, aCells As Variant)
With oDstRng
.Parent.Select
With .Resize( _
UBound(aCells, 1) - LBound(aCells, 1) + 1, _
UBound(aCells, 2) - LBound(aCells, 2) + 1)
.NumberFormat = "#"
.Value = aCells
End With
End With
End Sub
Finally Sub QuoteDataOutput(vJSON) input is a JSON object, to make it clear how the necessary data is being extracted from it, you may save the JSON string to file, copy the contents and paste it to any JSON viewer for further study. I use online tool http://jsonviewer.stack.hu, target element structure is shown below:
The output for me is as follows (first worksheet shown):
There are 9 main sections, the relevant part of the data is extracted and output to 9 worksheets:
IncomeStatementY
IncomeStatementQ
CashflowY
CashflowQ
BalanceSheetY
BalanceSheetQ
EarningsChartQ
FinancialsChartY
FinancialsChartQ
Having that example you can extract the data you need from that JSON response.
It turns out that Yahoo ended the application from which the web query drew its data. Thank you for all your tips.
I am trying to pull data from this website: http://securities.stanford.edu/filings.html?page=1
Each "page" is a table with 21 items. There are 97 pages I would like to pull data from, but I am unable to automate it so that the macro cycles through all 97, and places the results every 21 rows, starting on cell A1. (sequence: a1, a22, a43, ect...)
this what I got, but I dont want to edit the code 97 time to get all the pages. Any idea how I could automate the task?
Sub Macro1()
' Macro1 Macro
With ActiveSheet.QueryTables.Add(Connection:= _
"URL;http://securities.stanford.edu/filings.html?page=1", Destination:=Range( _
"A1"))
.Name = "filings.html?page=1"**
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlAllTables
.WebFormatting = xlWebFormattingNone
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
end Sub
For x = 1 to 97
With ActiveSheet.QueryTables.Add(Connection:= _
"URL;http://securities.stanford.edu/filings.html?page=" & x, Destination:=Range( _
"A" & (1 + ((x - 1) * 21)))
.Name = "filings.html?page=" & x
End With
Next
x contains page number and the cell is complicated to make it start at A1 rather than A21.
You could make it 0 to 96 and cell & (1 + (x + 21)) and the name and query x + 1.
I would abandon the 'from Web Query' method and delve into some xmlHTTP. For the following, you will have use the VBE's Tools ► References to add Microsoft HTML Object Library, Microsoft Internet Controls and Microsoft XML 6.0.
Option Explicit
Sub mcr_Collect_Filings()
Dim htmlBDY As HTMLDocument, xmlHTTP As New MSXML2.ServerXMLHTTP60
Dim rw As Long, pg As Long, iTH As Long, iTD As Long, iTR As Long
Dim eTBL As MSHTML.IHTMLElement
For pg = 1 To 99 '<-set to something reasonable; routine will kick out whehn it cannot find anything more
xmlHTTP.Open "GET", "http://securities.stanford.edu/filings.html?page=" & pg, False
xmlHTTP.setRequestHeader "Content-Type", "text/xml"
xmlHTTP.send
If xmlHTTP.Status <> "200" Then GoTo bm_CleanUp
Set htmlBDY = New HTMLDocument
htmlBDY.body.innerHTML = xmlHTTP.responseText
Set eTBL = htmlBDY.getElementById("records").getElementsByTagName("table")(0)
If eTBL Is Nothing Then GoTo bm_CleanUp
'skip the header row if on page 2 and above
With Sheet1 '<-worksheet codename
rw = .Cells(Rows.Count, 1).End(xlUp).Row
For iTR = (1 + (pg = 1)) To (eTBL.getElementsByTagName("tr").Length - 1)
For iTH = 0 To (eTBL.getElementsByTagName("tr")(iTR).getElementsByTagName("th").Length - 1)
.Cells(rw, 1).Offset(iTR, iTH) = _
eTBL.getElementsByTagName("tr")(iTR).getElementsByTagName("th")(iTH).innerText
Next iTH
For iTD = 0 To (eTBL.getElementsByTagName("tr")(iTR).getElementsByTagName("td").Length - 1)
.Cells(rw, 1).Offset(iTR, iTD) = _
eTBL.getElementsByTagName("tr")(iTR).getElementsByTagName("td")(iTD).innerText
Next iTD
Next iTR
End With
Next pg
bm_CleanUp:
Set eTBL = Nothing
Set htmlBDY = Nothing
Set xmlHTTP = Nothing
End Sub
The XMLHTTP is invisible so you have to know a little about the page and what to expect in the form of HTML code you are going to receive under different circumstances. A browser's Inspect Element command take care of that.
This is by far the fastest method in VBA. While you actually have more than 99 rows to retrieve, this went to 99 pages in 56.3 seconds. You might even speed that up a bit by turning off screen updating.
I have a Firebird database stored in Windows-1251 codepage and managed using IBExpert. I have to get some billing info using SQL, edit it and then send it to clients. I export query results into .csv (comma-separated values) format and then process a bunch of csvs into a pretty xls (with borders, fonts, etc.) using Microsoft Excel 2010. I have NO idea why, but IBExpert places a strange symbol everywhere in numeric values between decades (64 731 instead of 64731). Asc() method from VBA tells me that it's the #160 symbol in ASCII codepage.
NOW, the strangest observation I made: if you copy this symbol manually and delete it from everywhere using find/replace function of Excel, everything is OK. If you do the same thing in any text editor (e.g. good old notepad) everything is still OK. But when you try to automate the replacement using VBA, everything goes very, very wrong. No matter if you use a manually copied #160 from the csv itself or you generate it using Chr(160), if you try to delete all those, VBA also deletes half of the commas. By comma I mean generally known symbol #44, you can google "ascii" pictures and check it out. I have to mark that again, the replacement affects half the commas, however all of them actually ARE the very same symbol, I rechecked that twice.
You can look for a link to a csv below, so you can reassure yourself with the fact that I'm not crazy.
Here is the code you can use to reproduce the magic
Sub test()
Worksheets(1).UsedRange.Replace What:=Chr(160), Replacement:=""
End Sub
I'll be very thankful to someone who will clarify this phenomenon, because I just can't believe that VBA is that buggy, I think I missed something somewhere
UPDATE: Guys, I am terribly sorry. I'm so dumb that I've uploaded the wrong csv. Here's the right one
I've imported the CSV to Range("A1"). Here's what I've found:
$F$2 = 4 708,200
That value is not detected as a numeric. This is due to the CHR(160) existing in the 2nd place (the "space" after 4).
If you want that value to become 4708200 (four million...), replace CHR(160) like you've done. This removes the comma because now excel detects those values as numerics.
Since you haven't provided correct info, Excel thinks the comma is a thousands separator.
If it should rather be 4708,2 (four thousand...), correct it during your CSV import:
To import the CSV correctly, you have to put CHR(160) as a thousands separator.
The comma will act as a decimal sign.
This way, Excel will interpret 4 708,200 as the numeric value 4708,2 during import.
When using REPLACE in VBA, Excel assumes the comma is a thousands separator. Why? Hard to say. However, you haven't provided that it's NOT. :)
Below is the code for importing the file correctly.
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;H:\testfile2.csv", Destination:=Range("$A$1"))
.Name = "testfile2.csv"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 1251
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = True
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1)
.TextFileThousandsSeparator = Chr(160) ' Here's that thousands separator!
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
Update: Here's the code that replaces your previous Workbooks.OpenText macro.
Sub eyecandy()
Dim SelectedItem
Dim Wb As Workbook, Sh As Worksheet
Dim WbName As String, WbFullName As String
With Application.FileDialog(msoFileDialogFilePicker)
.Title = " "
.InitialFileName = ThisWorkbook.Path & Application.PathSeparator & "*.csv"
.AllowMultiSelect = True
If .Show = False Then Exit Sub
Application.ScreenUpdating = False
For Each SelectedItem In .SelectedItems
Set Wb = Workbooks.Add
' Get the file name
WbFullName = Replace(SelectedItem, ThisWorkbook.Path & Application.PathSeparator, "")
WbName = Replace(WbFullName, ".csv", "")
' Deletes unnecessary sheets
Do Until Wb.Sheets.Count = 1
Application.DisplayAlerts = False
Wb.Sheets(1).Delete
Application.DisplayAlerts = True
Loop
Set Sh = Wb.Sheets(1)
With Sh.QueryTables.Add(Connection:= _
"TEXT;" & SelectedItem, Destination:=Sh.Range("$A$1"))
.Name = WbName
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 1251
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = True
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1)
.TextFileThousandsSeparator = Chr(160)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
Sh.Activate
ActiveWindow.DisplayGridlines = False
With Sh.UsedRange
.Borders.LineStyle = xlContinuous
.Rows(1).Font.Bold = True
.Rows(1).Borders.Weight = xlThick
End With
Sh.Name = WbName
Wb.SaveAs Filename:=WbName, FileFormat:=56
Wb.Close SaveChanges:=False
Next SelectedItem
Application.ScreenUpdating = True
End With
End Sub
So, as #takl suggested, the solution was to modify thousand separator property.
It's .TextFileThousandsSeparator if you are using ActiveSheet.QueryTables.Add method and .ThousandsSeparator if you are using Workbooks.OpenText method.
I really appreciate his help, but I just have to use the Workbooks.OpenText method because it supports Local property. So, here's the edited file-processing loop from my script
'walk through selected files
For Each SelectedItem In .SelectedItems
Workbooks.OpenText _
Filename:=SelectedItem, _
Origin:=xlWindows, _
StartRow:=1, _
DataType:=xlDelimited, _
TextQualifier:=xlTextQualifierNone, _
ConsecutiveDelimiter:=False, _
Semicolon:=True, _
ThousandsSeparator:=Chr(160), _
Local:=True
I've been pretty new to Excel VBA, and I'm at some simple but stumping issues (might be from the overdose of coffee). My code currently pull tables from Yahoo Finance in a loop (so I can put in multiple tickers). What I'm trying to adjust is first inputting the tickers along a row instead of along a column - I tried changing all the "rows" of the lr1 line and that didnt do much. Secondly, I tried to figure out a way to pull the information so it's only the numbers, instead of having the entire table pulled out since its the same line items each time. It would help if I could also erase/overwrite my macro results everytime I click the refresh button.
The result would be as simple as putting in a ticker on one column at the top, and the numbers come out right underneath after hitting a button - I feel that I'm close, but no cigar.
This is the code that works, not the one riddled with as many mistakes.
Sub RefreshQuery()
On Error Resume Next
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim DestinationCell As Range
Dim StockSymbol As String
Dim i As Long, lr1 As Long, lr2 As Long
lr1 = Range("B:B").Find("*", LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
For i = 1 To QueryTables.Count
QueryTables(i).Delete
Next i
Range("C:D").Clear
For i = 2 To lr1
lr2 = Range("D:D").Find("*", LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Set DestinationCell = Cells((lr2 + 3), 4)
StockSymbol = Cells(i, 2).Value
Cells((lr2 + 2), 4).Value = "****" & StockSymbol & "****"
With QueryTables.Add(Connection:="URL;http://finance.yahoo.com/q/ks?s=" & StockSymbol & "+Key+Statistics", Destination:=DestinationCell)
.Name = "q/ks?s=" & StockSymbol & "+Key+Statistics"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingNone
.WebTables = "8,9,10,11,12,13,14,15,16,17,18,19,20,21,25,26,27,29"
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
Next i
Application.ScreenUpdating = False
Application.Calculation = xlCalculationAutomatic
End Sub
Thanks for all the help!
For only the numbers you do a query on another sheet. On your main sheet type =SheetWithYahooPage!b5 where you want the number only. It's easier to just pull the whole page in.
Queries have their own refresh abilities. Why are you doing it in code? Queries can delete the data. There are two dialogs for Queries. One called Options where you select the page. And another button called Properties on the last dialog where you are asked where to insert the data.