Related
I am trying to pull data from the website 'https://api.iextrading.com/1.0/stock/aapl/financials' onto an excel sheet (originally from https://iextrading.com/developer/docs/#financials). I have been able to pull data from 'https://api.iextrading.com/1.0/stock/aapl/chart/1y' using my code. I tried to alter it for the financials page, but I am getting stuck because I can't figure out how to access the array within the object, my array currently returns a length of 2, ie 'symbol' and 'financials'.
Here is my code:
'write to ws
Dim ws As Worksheet
Set ws = Sheets("Ratios")
Dim ticker As String
ticker = ws.Range("P7").Value
Dim lastrow As Integer
lastrow = ws.Cells(Rows.Count, "A").End(xlUp).row
'clear range
ws.Range("A1:L" & lastrow).Clear
'array col headers
Dim myarray As Variant
myarray = Array("reportDate", "grossProfit", "costOfRevenue", "operatingRevenue", "totalRevenue", "operatingIncome", "netIncome", "researchAndDevelopment", "operatingExpense", "currentAssets", "totalAssets", "totalLiabilities", "currentCash", "currentDebt", "totalCash", "totalDebt", "shareholderEquity", "cashChange", "cashFlow", "operatingGainsLosses")
arrsize = UBound(myarray) - LBound(myarray) + 1
Dim rngTarget As Range
Set rngTarget = ws.Range(Cells(1, 1), Cells(1, arrsize))
rngTarget = myarray
'send web requests for API data
u = "https://api.iextrading.com/1.0/stock/aapl/financials"
Set MyRequest = CreateObject("WinHttp.WinHttpRequest.5.1")
MyRequest.Open "Get", u
MyRequest.Send
'parse Json
Dim json As Object
Set json = JsonConverter.ParseJson(MyRequest.ResponseText)
'get # of objects in Array
Dim arraylen As Integer
arraylen = json.Count
MsgBox (arraylen)
'loop through elements
Dim elements As Variant
Dim x, y, r As Integer
r = 2
y = 1
x = 1
While x < arraylen + 1
For Each element In myarray
ws.Cells(r, y).Value = json(x)(element)
y = y + 1
Next element
y = 1
x = x + 1
r = r + 1
Wend
End Sub
I also get a type mismatch regarding the json(x)(element).
What can I add to my code so that I can access the array within the object 'financials'?
You need a double For Loop. [] are collections accessed by index and {} are dictionaries accessed by key. The returned object is a dictionary and you need the key financials to return the collection of dictionaries within.
Option Explicit
Public Sub GetData()
Dim json As Object, results(), item As Object, headers()
Dim key As Variant, ws As Worksheet, r As Long, c As Long
Set ws = ThisWorkbook.Worksheets("Sheet1")
With CreateObject("MSXML2.XMLHTTP")
.Open "GET", "https://api.iextrading.com/1.0/stock/aapl/financials", False
.send
Set json = JsonConverter.ParseJson(.responseText)("financials")
ReDim results(1 To json.Count, 1 To json.item(1).Count)
headers = json.item(1).keys
For Each item In json
r = r + 1: c = 1
For Each key In item.keys
results(r, c) = item(key)
c = c + 1
Next
Next
End With
With ws
.Cells(1, 1).Resize(1, UBound(headers) + 1) = headers
.Cells(2, 1).Resize(UBound(results, 1), UBound(results, 2)) = results
End With
End Sub
This code (like other codes) written by Precious #QHarr works well. However, when importing data, I want to retrieve the data saved in the connection. The output of the code and the data I want to receive are shown in the attached image. What kind of code can I solve? (Google Translate)
Public Sub DYarislar()
Dim asays(), ws As Worksheet, asay As Long, html As HTMLDocument
Dim http As clsHTTP, url As String, headers(), numberOfRequests As Long
headers = Array("Asay", "Tarih", "Sehir", "K.Cinsi", "Gr", "Msf/Pist", "Derece", "S", "Jokey", "Kilo", "G.Ç", "Hnd", "Gny", "Taki")
Set http = New clsHTTP
Set ws = ThisWorkbook.Worksheets("X")
Set html = New HTMLDocument
asays = Application.Transpose(Sheets("Y").Range("A2:A" & Sheets("Y").Columns("A:A").Find(What:="boş").Row - 1).Value)
Const numTableRows As Long = 250
Const numTableColumns As Long = 14
Const BASE_URL As String = "https://yenibeygir.com/at/"
numberOfRequests = UBound(asays)
Dim results(), headerRow As Boolean, tRows As Object, tRow As Object, iRow As Long
Dim tCells As Object, tCell As Object, r As Long, c As Long, hTable As HTMLTable
ReDim results(1 To numTableRows * numberOfRequests, 1 To numTableColumns)
Application.ScreenUpdating = False
For asay = 1 To numberOfRequests
headerRow = True
url = BASE_URL & asays(asay)
html.body.innerHTML = http.GetString(url)
Set hTable = html.querySelector(".at_Yarislar")
Set tRows = hTable.getElementsByTagName("tr")
Const numberOfRaces As Long = 22
Dim counter As Long
counter = 1
For Each tRow In tRows
If Not headerRow Then
counter = counter + 1
If counter > numberOfRaces Then Exit For
c = 2: r = r + 1
results(r, 1) = asays(asay)
Set tCells = tRow.getElementsByTagName("td")
For Each tCell In tCells
results(r, c) = tCell.innerText
c = c + 1
Next
End If
headerRow = False
Next
Next
With ws
.Cells(1, 1).Resize(1, UBound(headers) + 1) = headers
.Cells(2, 1).Resize(UBound(results, 1), UBound(results, 2)) = results
End With
Application.ScreenUpdating = True
End Sub
You only need a few small changes. You use the same Class, clsHTTP, as before, then use the module 1 code below.
Notes:
Within each source page table row the jockey column contains an a tag link element
You can access this using:
tRow.getElementsByTagName("a")(1).href
As the link is relative you need to do a text replacement to add in the base part of the URL i.e.
Replace$(tRow.getElementsByTagName("a")(1).href, "about:", BASE_URL2)
The id is part of the href and can be extracted using Split:
Split(tRow.getElementsByTagName("a")(1).href, "/")(2)
To allow for these additional elements in the results you need to increase the number of output column count:
Const numTableColumns As Long = 16
And adapt your table rows loop to populate the additional columns:
results(r, 2) = Split(tRow.getElementsByTagName("a")(1).href, "/")(2)
results(r, 3) = Replace$(tRow.getElementsByTagName("a")(1).href, "about:", BASE_URL2)
Also, adjust in the loop to ensure other columns are populated from the 4th onwards (as 2 extra columns):
c = 4
Finally, adjust your headers to include the 2 new columns:
headers = Array("Asay", "JokeyId", "JokeyLink", "Tarih", "Sehir", "K.Cinsi", "Gr", "Msf/Pist", "Derece", "S", "Jokey", "Kilo", "G.Ç", "Hnd", "Gny", "Taki")
VBA:
Module 1:
Option Explicit
Public Sub DYarislar()
Dim asays(), ws As Worksheet, asay As Long, html As HTMLDocument
Dim http As clsHTTP, url As String, headers(), numberOfRequests As Long
headers = Array("Asay", "JokeyId", "JokeyLink", "Tarih", "Sehir", "K.Cinsi", "Gr", "Msf/Pist", "Derece", "S", "Jokey", "Kilo", "G.Ç", "Hnd", "Gny", "Taki")
Set http = New clsHTTP
Set ws = ThisWorkbook.Worksheets("X")
Set html = New HTMLDocument
asays = Application.Transpose(Sheets("Y").Range("A2:A" & Sheets("Y").Columns("A:A").Find(What:="boş").Row - 1).Value)
Const numTableRows As Long = 250
Const numTableColumns As Long = 16
Const BASE_URL As String = "https://yenibeygir.com/at/"
Const BASE_URL2 As String = "https://yenibeygir.com"
numberOfRequests = UBound(asays)
Dim results(), headerRow As Boolean, tRows As Object, tRow As Object, iRow As Long
Dim tCells As Object, tCell As Object, r As Long, c As Long, hTable As HTMLTable
ReDim results(1 To numTableRows * numberOfRequests, 1 To numTableColumns)
Application.ScreenUpdating = False
For asay = 1 To numberOfRequests
headerRow = True
url = BASE_URL & asays(asay)
html.body.innerHTML = http.GetString(url)
Set hTable = html.querySelector(".at_Yarislar")
Set tRows = hTable.getElementsByTagName("tr")
For Each tRow In tRows
If Not headerRow Then
c = 4: r = r + 1
results(r, 1) = asays(asay)
On Error Resume Next
results(r, 2) = Split(tRow.getElementsByTagName("a")(1).href, "/")(2)
results(r, 3) = Replace$(tRow.getElementsByTagName("a")(1).href, "about:", BASE_URL2)
On Error GoTo 0
Set tCells = tRow.getElementsByTagName("td")
For Each tCell In tCells
results(r, c) = tCell.innerText
c = c + 1
Next
End If
headerRow = False
Next
Next
With ws
.Cells(1, 3).Resize(1, UBound(headers) + 1) = headers
.Cells(2, 3).Resize(UBound(results, 1), UBound(results, 2)) = results
End With
Application.ScreenUpdating = True
End Sub
Sample results:
I have two tables and require the first table to be updated as the third screen shot.
This is the first table. The VON is the first value of the range. This value is picked up from the second table till the BIS value is reached. While the BIS value is reached in the second table, the RANGE column is updated with the values between VON and BIS values.
The second table contains sequentially listed values from 01 to 99 and alphanumeric values such as A1, A2 etc.
Any suggestions?
Try This:
Option Explicit
Sub ExpandRows()
Dim rgLastCell As Range
Dim rgThisRow As Range
Dim wsMaster As Worksheet
Dim wsNewSheet As Worksheet
Dim rgThisRecord As Range
Dim intVon As Integer
Dim intRes As Integer
Dim dblCopyRowNumber As Double
Set wsMaster = ActiveSheet
Set wsNewSheet = Worksheets.Add(after:=wsMaster)
wsNewSheet.Name = "Output"
Set rgLastCell = GetLastCell(wsMaster)
dblCopyRowNumber = 2
wsMaster.Rows(1).Copy wsNewSheet.Range("A1")
wsmaster.columns.autofit
For Each rgThisRow In Range("A2:A" & rgLastCell.Row)
Set rgThisRecord = wsMaster.Range(Cells(rgThisRow.Row, 1).Address, Cells(rgThisRow.Row, rgLastCell.Column).Address)
Debug.Print rgThisRecord.Address
If IsNumeric(rgThisRecord(8)) Then
intVon = rgThisRecord(8).Value
intRes = rgThisRecord(9).Value
While intVon <= intRes
rgThisRecord.Copy wsNewSheet.Range("A" & dblCopyRowNumber)
wsNewSheet.Cells(dblCopyRowNumber, 11).Value = intVon
dblCopyRowNumber = dblCopyRowNumber + 1
intVon = intVon + 1
Wend
Else
rgThisRecord.Copy wsNewSheet.Range("A" & dblCopyRowNumber)
dblCopyRowNumber = dblCopyRowNumber + 1
End If
Next
Set rgLastCell = Nothing
Set rgThisRow = Nothing
Set wsMaster = Nothing
Set wsNewSheet = Nothing
Set rgThisRecord = Nothing
End Sub
and this is the find last cell function:
Function GetLastCell(ByVal wsCurrentSheet As Worksheet) As Range
Dim rgLastRow As Range
Dim rglastColumn As Range
Dim rgLastCell As Range
Set rgLastRow = wsCurrentSheet.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious)
Set rglastColumn = wsCurrentSheet.Cells.Find("*", searchorder:=xlByColumns, searchdirection:=xlPrevious)
Set GetLastCell = wsCurrentSheet.Cells(rgLastRow.Row, rglastColumn.Column)
Set rgLastCell = Nothing
Set rgLastRow = Nothing
Set rglastColumn = Nothing
End Function
Hope that helps.
I found a solution for parsing JSON, and it works fine for the presented example:
Here's the code:
Sub Test()
Dim jsonText As String
Dim jsonObj As Dictionary
Dim jsonRows As Collection
Dim jsonRow As Collection
Dim ws As Worksheet
Dim currentRow As Long
Dim startColumn As Long
Dim i As Long
Set ws = Worksheets("VIEW")
'Create a real JSON object
jsonText = ws.Range("A1").Value
'Parse it
Set jsonObj = JSON.parse(jsonText)
'Get the rows collection
Set jsonRows = jsonObj("rows")
'Set the starting row where to put the values
currentRow = 1
'First column where to put the values
startColumn = 2 'B
'Loop through all the values received
For Each jsonRow In jsonRows
'Now loop through all the items in this row
For i = 1 To jsonRow.Count
ws.Cells(currentRow, startColumn + i - 1).Value = jsonRow(i)
Next i
'Increment the row to the next one
currentRow = currentRow + 1
Next jsonRow
End Sub
And the JSON that is working:
{"rows":[["20120604", "ABC", "89"],["20120604", "BCD", "120"],["20120604", "CDE","239"]]}
However I need to parse JSON that has a structure like this:
[{"Id":"2604","Price": 520.4, "State": true},{"Id":"2605","Price": 322.8, "State": false},{"Id":"2619","Price": 104.7, "State": true},{"Id":"2628","Price": 182.2, "State": true}]
That means, in this case, It should be 3 columns (Id, Price, Status) and 4 rows.
It should be easy but I am just a total newbie here..
Should be something like this:
Dim jsonRows As Collection
Dim jsonRow As Dictionary
'...
'Parse it
Set jsonRows = JSON.parse(jsonText)
'Set the starting row where to put the values
currentRow = 1
'First column where to put the values
startColumn = 2 'B
'Loop through all the values received
For Each jsonRow In jsonRows
'Now set all the values in this row
ws.Cells(currentRow, startColumn).Value = jsonRow("Id")
ws.Cells(currentRow, startColumn + 1).Value = jsonRow("Price")
ws.Cells(currentRow, startColumn + 2).Value = jsonRow("State")
'Increment the row to the next one
currentRow = currentRow + 1
Next jsonRow
It's been years since I last had to code anything, but now I seem to need it again.
To simplify, I have number 7 in column A, and I need to input another number in column B depending on what number 7 relates to in another table in another sheet.
So in Sheet2 another table has numbers ranging from 1 to 10 in column A, and according numbers in column B. I then need it to search for number 7 in column A of sheet2 and give me the number in column B, and place it in column B in the first sheet.
I have tried a For loop inside a For loop, based on another code I found somewhere, but it's been so long ago I would need to spend hours rereading and trying to get near a solution. Maybe this is an easy thing for advanced coders?
Anyways, thanks in advance for the help!
couldn't you ever help without VBA then you can use this
Option Explicit
Sub main()
Dim cell As Range, f As Range
Dim rng1 As Range, rng2 As Range
Set rng1 = Worksheets("Sht1").Columns(1).SpecialCells(xlCellTypeConstants) '<--Change "Sht1" to your actual sheet1 name
Set rng2 = Worksheets("Sht2").Columns(1).SpecialCells(xlCellTypeConstants) '<--Change "Sht2" to your actual sheet2 name
For Each cell In rng1
Set f = rng2.Find(what:=cell.Value2, LookIn:=xlValues, lookat:=xlWhole, MatchCase:=xlNo)
If Not f Is Nothing Then cell.Offset(, 1) = f.Offset(, 1)
Next cell
End Sub
Here are two ways of doing searching over two tables.
Sub LoopValues()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim wsSource As Worksheet, wsSearch As Worksheet
Dim sourceLastRow As Long, searchLastRow As Long
Dim i As Long, j As Long
Set wsSource = Worksheets("Sheet3")
Set wsSearch = Worksheets("Sheet4")
With wsSource
sourceLastRow = .Range("A" & Rows.Count).End(xlUp).Row
searchLastRow = wsSearch.Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To sourceLastRow
For j = 2 To sourceLastRow
If .Cells(i, 1).Value = wsSearch.Cells(j, 1).Value Then .Cells(i, 2).Value = wsSearch.Cells(j, 2).Value
Next
Next
End With
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Sub FindValuesLoop()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim wsSource As Worksheet, wsSearch As Worksheet
Dim sourceLastRow As Long
Dim i As Long
Dim SearchRange As Range, rFound As Range
Set wsSource = Worksheets("Sheet3")
Set wsSearch = Worksheets("Sheet4")
With wsSource
sourceLastRow = .Range("A" & Rows.Count).End(xlUp).Row
Set SearchRange = wsSearch.Range(wsSearch.Range("A1"), wsSearch.Range("A" & Rows.Count).End(xlUp))
For i = 2 To sourceLastRow
Set rFound = SearchRange.Find(What:=.Cells(i, 1).Value, LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
If Not rFound Is Nothing Then .Cells(i, 2).Value = rFound.Offset(0, 1).Value
Next
End With
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub