It takes about 1 second per row to run, so it is not fast, but it seems to work OK.
For Yahoo Finance, you will need to add a suffix for London (.L) or Germany (.DE) or Paris (.PA) stocks. NYSE stocks don't need a suffix. Use .ST for Toronto exchange - e.g. LUG.ST.
The whole thing took me 10 minutes. There were a few syntax errors, etc. but I just told Claude what they were and the AI fixed them. I managed to get a working version before my free time on Claude expired.
I then added an update button to my sheet so I could quickly run the macro.
The VBA code is shown below:
Sub GetETFPrices()
' Process single ticker in selected row or A2
Dim ticker As String
Dim currentPrice As Double
Dim avgPrice As Double
Dim ws As Worksheet
Dim http As Object
Dim url As String
Dim response As String
Dim i As Long
Dim sum As Double
Dim count As Long
Dim jsonText As String
Dim targetRow As Long
' Set worksheet
Set ws = ActiveSheet
' Determine which row to process
If ActiveCell.Row >= 2 And ActiveCell.Column = 1 Then
targetRow = ActiveCell.Row
Else
targetRow = 2
End If
' Get ticker from selected row
ticker = Trim(ws.Cells(targetRow, 1).Value)
If ticker = "" Then
MsgBox "Please enter an ETF ticker symbol in cell A2", vbExclamation
Exit Sub
End If
' Try alternate API endpoint first
On Error GoTo TryAlternate
' Create HTTP object
Set http = CreateObject("MSXML2.XMLHTTP.6.0")
' Use Yahoo Finance download endpoint (more reliable)
Dim endDate As Date
Dim startDate As Date
Dim endUnix As Long
Dim startUnix As Long
endDate = Date
startDate = DateAdd("d", -35, Date) ' Get extra days to ensure 30 trading days
endUnix = DateDiff("s", DateSerial(1970, 1, 1), endDate)
startUnix = DateDiff("s", DateSerial(1970, 1, 1), startDate)
' Build download URL
url = "https://query1.finance.yahoo.com/v7/finance/download/" & ticker & _
"?period1=" & startUnix & "&period2=" & endUnix & "&interval=1d&events=history"
' Send request with headers
http.Open "GET", url, False
http.setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36"
http.send
' Check response
If http.Status = 200 Then
response = http.responseText
' Parse CSV response
Dim lines() As String
Dim fields() As String
Dim priceCol As Integer
lines = Split(response, vbLf)
If UBound(lines) < 2 Then
GoTo TryAlternate
End If
' Find Close column (usually column 4)
fields = Split(lines(0), ",")
priceCol = -1
For i = 0 To UBound(fields)
If Trim(fields(i)) = "Close" Or Trim(fields(i)) = "Adj Close" Then
priceCol = i
Exit For
End If
Next i
If priceCol = -1 Then priceCol = 4 ' Default to column 4
' Parse prices
sum = 0
count = 0
currentPrice = 0
For i = 1 To UBound(lines)
If Len(Trim(lines(i))) > 0 Then
fields = Split(lines(i), ",")
If UBound(fields) >= priceCol Then
If IsNumeric(fields(priceCol)) Then
Dim price As Double
price = CDbl(fields(priceCol))
If price > 0 Then
sum = sum + price
count = count + 1
currentPrice = price ' Last valid price
End If
End If
End If
End If
Next i
If count > 0 Then
avgPrice = sum / count
' Output results to target row
ws.Cells(targetRow, 2).Value = currentPrice
ws.Cells(targetRow, 3).Value = avgPrice
ws.Cells(targetRow, 4).Value = currentPrice - avgPrice
ws.Cells(targetRow, 5).Value = Format((currentPrice - avgPrice) / avgPrice, "0.00%")
' Format as numbers
ws.Range(ws.Cells(targetRow, 2), ws.Cells(targetRow, 4)).NumberFormat = "#,##0.00"
' Color code the percentage change cell
Call ColorCodeCell(ws.Cells(targetRow, 5))
MsgBox "Data retrieved successfully!" & vbCrLf & _
"Ticker: " & ticker & vbCrLf & _
"Current Price: " & Format(currentPrice, "#,##0.00") & vbCrLf & _
"Average Price (last " & count & " days): " & Format(avgPrice, "#,##0.00"), vbInformation
Exit Sub
End If
End If
TryAlternate:
' If first method fails, try the chart API
On Error GoTo ErrorHandler
Set http = CreateObject("MSXML2.XMLHTTP.6.0")
url = "https://query1.finance.yahoo.com/v8/finance/chart/" & ticker & _
"?range=1mo&interval=1d"
http.Open "GET", url, False
http.setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36"
http.setRequestHeader "Accept", "*/*"
http.send
If http.Status <> 200 Then
MsgBox "Unable to fetch data for: " & ticker & vbCrLf & vbCrLf & _
"Status: " & http.Status & vbCrLf & vbCrLf & _
"Tips:" & vbCrLf & _
"- Check ticker symbol is correct" & vbCrLf & _
"- For European ETFs use: EQQQ.L, EQQQ.DE" & vbCrLf & _
"- Try again in a few moments", vbCritical
Exit Sub
End If
response = http.responseText
' Parse JSON for prices
Dim closePos As Long
Dim closePrices As String
closePos = InStr(response, """close"":[")
If closePos > 0 Then
closePos = closePos + 10
Dim endPos As Long
endPos = InStr(closePos, response, "]")
closePrices = Mid(response, closePos, endPos - closePos)
' Clean and split
closePrices = Replace(closePrices, "null,", "")
closePrices = Replace(closePrices, ",null", "")
Dim priceArray() As String
priceArray = Split(closePrices, ",")
sum = 0
count = 0
For i = LBound(priceArray) To UBound(priceArray)
If IsNumeric(Trim(priceArray(i))) Then
price = CDbl(Trim(priceArray(i)))
If price > 0 Then
sum = sum + price
count = count + 1
currentPrice = price
End If
End If
Next i
If count > 0 Then
avgPrice = sum / count
' Output results to target row
ws.Cells(targetRow, 2).Value = currentPrice
ws.Cells(targetRow, 3).Value = avgPrice
ws.Cells(targetRow, 4).Value = currentPrice - avgPrice
ws.Cells(targetRow, 5).Value = Format((currentPrice - avgPrice) / avgPrice, "0.00%")
ws.Range(ws.Cells(targetRow, 2), ws.Cells(targetRow, 4)).NumberFormat = "#,##0.00"
' Color code the percentage change cell
Call ColorCodeCell(ws.Cells(targetRow, 5))
' MsgBox "Data retrieved successfully!" & vbCrLf & _
"Ticker: " & ticker & vbCrLf & _
"Current Price: " & Format(currentPrice, "#,##0.00") & vbCrLf & _
"Average (last " & count & " days): " & Format(avgPrice, "#,##0.00"), vbInformation
Else
MsgBox "No valid price data found for: " & ticker, vbExclamation
End If
Else
MsgBox "Could not parse data for: " & ticker & vbCrLf & vbCrLf & _
"The ticker may not exist or Yahoo Finance API may be unavailable.", vbExclamation
End If
Exit Sub
ErrorHandler:
MsgBox "Error occurred: " & Err.Description & vbCrLf & vbCrLf & _
"This may be due to:" & vbCrLf & _
"- Network connectivity issues" & vbCrLf & _
"- Yahoo Finance API rate limiting" & vbCrLf & _
"- Invalid ticker symbol", vbCritical
End Sub
Sub SetupWorksheet()
Dim ws As Worksheet
Set ws = ActiveSheet
ws.Range("A1").Value = "Ticker"
ws.Range("B1").Value = "Current Price"
ws.Range("C1").Value = "30-Day Average"
ws.Range("D1").Value = "Difference"
ws.Range("E1").Value = "% Change"
' Format headers
ws.Range("A1:E1").Font.Bold = True
ws.Range("A1:E1").Interior.Color = RGB(200, 200, 200)
' Add examples
ws.Range("A2").Value = "SPY"
ws.Range("A3").Value = "EQQQ.L"
ws.Range("A4").Value = "QQQ"
' Add note
ws.Range("A6").Value = "Note: European ETFs need exchange suffix"
ws.Range("A7").Value = ".L = London, .DE = Germany, .PA = Paris"
ws.Range("A6:A7").Font.Italic = True
ws.Range("A6:A7").Font.Size = 9
ws.Columns("A:E").AutoFit
MsgBox "Setup complete! Enter a ticker in A2 and run GetETFPrices", vbInformation
End Sub
Sub GetAllETFPrices()
' Process all tickers in column A
Dim ws As Worksheet
Dim lastRow As Long
Dim i As Long
Dim successCount As Long
Dim failCount As Long
Dim startTime As Double
Set ws = ActiveSheet
successCount = 0
failCount = 0
startTime = Timer
' Find last row with data in column A
lastRow = ws.Cells(ws.Rows.count, "A").End(xlUp).Row
If lastRow < 2 Then
MsgBox "No tickers found. Add tickers starting in cell A2", vbExclamation
Exit Sub
End If
' Disable screen updating for speed
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
' Loop through each ticker
For i = 2 To lastRow
If ws.Cells(i, 1).Value <> "" And Not ws.Cells(i, 1).Font.Italic Then
' Select the row
ws.Cells(i, 1).Select
' Process this ticker
On Error Resume Next
Call GetETFPrices
' Check if data was populated
If ws.Cells(i, 2).Value <> "" Then
successCount = successCount + 1
Else
failCount = failCount + 1
End If
On Error GoTo 0
DoEvents
' Small delay to avoid rate limiting
Application.Wait (Now + TimeValue("0:00:01"))
End If
Next i
' Re-enable screen updating
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
' Show summary
Dim elapsed As Double
elapsed = Timer - startTime
MsgBox "Batch processing complete!" & vbCrLf & vbCrLf & _
"Successful: " & successCount & vbCrLf & _
"Failed: " & failCount & vbCrLf & _
"Time: " & Format(elapsed, "0.0") & " seconds", vbInformation
End Sub
Sub ColorCodeCell(cell As Range)
' Color code cell based on percentage value
Dim pctValue As Double
' Extract numeric value from percentage
If IsNumeric(cell.Value) Then
pctValue = cell.Value
Else
' Try to parse if it's formatted as text
Dim strValue As String
strValue = Replace(cell.Text, "%", "")
If IsNumeric(strValue) Then
pctValue = CDbl(strValue) / 100
Else
Exit Sub
End If
End If
' Apply color based on thresholds
If pctValue > 0.03 Then
' Dark green: > 3%
cell.Interior.Color = RGB(0, 176, 80)
cell.Font.Color = RGB(255, 255, 255)
ElseIf pctValue > 0 Then
' Light green: 0% to 3%
cell.Interior.Color = RGB(198, 239, 206)
cell.Font.Color = RGB(0, 0, 0)
ElseIf pctValue > -0.03 Then
' Light red: 0% to -3%
cell.Interior.Color = RGB(255, 199, 206)
cell.Font.Color = RGB(0, 0, 0)
Else
' Dark red: < -3%
cell.Interior.Color = RGB(192, 0, 0)
cell.Font.Color = RGB(255, 255, 255)
End If
End Sub
Claude even told me how to add the VBA code and add a button.
You can run SetupWorksheet first to set up the columns and a few dummy entries. The button uses GetAllETFPrices to update the cells.
There are instructions on YouTube for how to add a button to execute a macro and how to add VBA code. Tip: Alt+F8 and Alt+F11 are useful!
No comments:
Post a Comment