It will use a list of HYPTUSS portfolio epics to go through a set of date-based news-releases, defaulting to 'todays date', and will then list relevant RNS details for that date, only when relevant to the currently held portfolio.
Here's some quick and dirty instructions if anyone wants to have a play ON A COPY of their current Excel HYPTUSS file -
1. Create a new sheet - called 'RNS News' or similar
2. From the 'Developer' tab, insert an 'Active X' command button on the sheet
3. In 'Design Mode', double-click the above command button and DELETE the two default lines of VBA code (default VBA password for HYPTUSS is 'pleaseletmein')
4. Copy and paste the following Excel VBA code onto the above command button (note - there's a 'Select all' button at the top of the following CODE window, to help with then doing a CTRL-C copy of all the code...) -
Code: Select all
Private Sub CommandButton1_Click()
Dim epic_string, company, midbit, rns_epic, date_to_use As String
Dim lastrow, done, rowsdown, rowdown, pno As Single
Dim do_again, elems, openPos, closePos As Single
Dim startrow, checkitem As Single
Dim oXMLHTTP, html, nodeColumnElements As Object
' Build a string of current portfolio holding EPICS
Let epic_string = ""
Let lastrow = Sheets("High Yield Portfolio").Range("C65536").End(xlUp).Row
For rowsdown = 6 To lastrow
Let done = 0
' Convert some known odd-ball EPICS to the required Investegate format (BT-A and all 2-character EPICs for now - there may be more..)
If Sheets("High Yield Portfolio").Cells(rowsdown, 3) = "BT-A" Then
epic_string = epic_string + "(BT.A)"
Let done = 1
ElseIf Len(Sheets("High Yield Portfolio").Cells(rowsdown, 3)) = 2 Then
epic_string = epic_string + "(" & Sheets("High Yield Portfolio").Cells(rowsdown, 3) & ".)"
Let done = 1
End If
If done = 0 Then
epic_string = epic_string & "(" & Sheets("High Yield Portfolio").Cells(rowsdown, 3) & ")"
End If
Next rowsdown
' Clear the current RNS list in the first four columns of the sheet
Columns("A:D").Select
Selection.ClearContents
Range("G3").Select
' Insert some column headings on the first row
Cells(1, 1) = "Time"
Cells(1, 2) = "Company"
Cells(1, 3) = "Announcement"
Cells(1, 4) = "URL Link"
' Parse todays RNS pages and pull out any relevant RNS articles (ignores Form8.x, Director/PDMR Shareholding, and Transaction in Own Shares news items)
Set html = CreateObject("htmlfile") ' New MSHTML.HTMLDocument
Set oXMLHTTP = CreateObject("Microsoft.XMLHTTP")
Let rowdown = 2
Let pno = 1
Let do_again = 1
' Ask the user for the YYYYMMDD format date to be used - prefill text box with today's date to help
date_to_use = InputBox("Please enter the date to be searched - " & vbCrLf & "Date format YYYYMMDD (Default is todays date)", "Date -", Format(Date, "YYYYMMDD"))
' Loop through all RNS pages on that date, and pull out EPIC-relevant RNS articles
Do While do_again = 1
' Open the Investegate website for the relevant share, and then scrape the data
oXMLHTTP.Open "GET", "https://www.investegate.co.uk/Index.aspx?date=" & date_to_use & "&arch=1" & "&pno=" & pno & "&cb=" & Timer() * 100, False
oXMLHTTP.send
html.body.innerHTML = oXMLHTTP.responseText
' Check to see if this is the last page of RNS articles for today, or if we're going to carry on after this page
If InStr(html.body.innerHTML, "pno=" & pno + 1) = 0 Then
do_again = 0
End If
Set nodeColumnElements = html.getElementsByTagName("td")
For elems = 0 To nodeColumnElements.Length - 1
If (InStr(nodeColumnElements(elems).innerHTML, "STRONG") > 0 Or InStr(nodeColumnElements(elems).innerHTML, "strong") > 0) _
And InStr(nodeColumnElements(elems).innerHTML, "(") > 0 _
And InStr(nodeColumnElements(elems).innerHTML, ")") > 0 _
And InStr(nodeColumnElements(elems + 1).innerText, "Form 8.") < 1 _
And InStr(nodeColumnElements(elems + 1).innerText, "Director/PDMR Shareholding") < 1 _
And InStr(nodeColumnElements(elems + 1).innerText, "Transaction in Own Shares") < 1 Then
' Find if RNS EPIC is in EPIC_STRING
Let company = nodeColumnElements(elems).innerText
openPos = InStr(company, "(")
On Error Resume Next
closePos = InStr(company, ")")
On Error Resume Next
midbit = Mid(company, openPos + 1, closePos - openPos - 1)
If openPos <> 0 And Len(midbit) > 0 Then
rns_epic = "(" & midbit & ")"
End If
' It's a portfolio-relevant RNS news article, so insert the information onto the worksheet
If InStr(epic_string, rns_epic) > 0 Then
Cells(rowdown, 1) = nodeColumnElements(elems - 4).innerText ' TIME
Cells(rowdown, 2) = nodeColumnElements(elems).innerText ' COMPANY NAME AND (EPIC)
Cells(rowdown, 3) = nodeColumnElements(elems + 1).innerText ' RNS TITLE
Cells(rowdown, 4) = Replace(nodeColumnElements(elems + 1).getElementsByTagName("A")(0).href, "about:", "https://www.investegate.co.uk") ' URL TO RNS ITEM
Let rowdown = rowdown + 1
End If
Let elems = elems + 2
End If
Next elems
' Loop to the next RNS page whilst variable do_again = 1
pno = pno + 1
Loop
End Sub
5. Come out of 'Design Mode' on the Developer tab
6. Click the Command Button
7. Use default date or alter to suit - the entered date must be in YYYYMMDD format, so it's 20220506 for today, 20220505 for yesterday, etc...
Hope it's useful, and I'd be interested to hear any feedback.
Cheers,
Itsallaguess