VBA script for Companies House - not working anymore? Thanks for checking

[boxhamster]

I had this script made by a mate once, but now something is not working anymore. It's says "done", but actually cells were not populated with values. What it does it takes a company name in cell A and then populates cells B-E with CRN SIC Postcode Addresss.
I'd be very grateful for some help. From what I see, it enters the company and searches for it, but then when trying to go to /company/CRN number the pages doesn't work. Not sure how to fix this?
Thanks for looking and helping.

Sub companieshouse()
Dim lastrow As Long
Dim whblock() As String
Dim siccon As Integer
Dim remspace As String
Dim final As String
Dim ie As New InternetExplorer
siccon = 0
lastrow = ActiveSheet.Range("A:A").End(xlDown).Row  

  ie.Visible = True
For I = 2 To lastrow
remspace = Replace(ActiveSheet.Range("A" & I).Value, " ", "+")
final = Replace(remspace, "&", "%26")  
  ie.navigate "[URL]https://beta.companieshouse.gov.uk/search/companies?q=[/URL]" & final
Do
DoEvents
Loop Until ie.readyState = READYSTATE_COMPLETE
Dim doc As New HTMLDocument
Set doc = ie.document
Dim name, name2 As String
name = doc.getElementsByTagName("li")(4).innerText  
  If Not doc.getElementsByTagName("li")(4) Is Nothing Then
whblock() = Split(name, vbCrLf)  
  If InStr(1, whblock(0), UCase(ActiveSheet.Range("A" & I).Value)) > 0 Then
ActiveSheet.Range("B" & I).Value = Trim(Mid(whblock(1), 1, InStr(1, whblock(1), "-") - 1))
ActiveSheet.Range("D" & I).Value = Mid(whblock(2), InStrRev(whblock(2), ",") + 1)
ActiveSheet.Range("E" & I).Value = Mid(whblock(2), 1, InStrRev(whblock(2), ",") - 1)  
  End If  
  [B]ie.navigate "[URL]https://beta.companieshouse.gov.uk/company/[/URL]" & ActiveSheet.Range("B" & I).Value[/B]
Do
DoEvents
Loop Until ie.readyState = READYSTATE_COMPLETE  
  Set doc = ie.document  
  Do Until doc.getElementById("sic" & siccon) Is Nothing
name2 = name2 & vbCrLf & doc.getElementById("sic" & siccon).innerText
siccon = siccon + 1
Loop  
  ActiveSheet.Range("C" & I).Value = Replace(name2, vbCrLf, "", 1, 1)  
  name = ""
name2 = ""
Erase whblock()
siccon = 0  
  End If  
  Next
ie.Quit
MsgBox "Done"
End Sub

 

[Kenneth Hobson]

I don't have your access. Does this help?

'ie.navigate "https://beta.companieshouse.gov.uk/search/companies?q=" & final
ie.navigate "https://beta.companieshouse.gov.uk/company/" & final

 

[boxhamster]

I tried and I'm afraid it doesn't change it, I'm afraid.

 

[Kenneth Hobson]

It is probably in the parsing routine. Can you detail one example and the expected results? Post and manually marked up one to a site like dropbox.com if you like. Screen pics of a manual navigation might help too.

I looked at Trade Limited, col A value of 02693994, in my test and had no parsed results returned either.

 

[boxhamster]

It is probably in the parsing routine. Can you detail one example and the expected results? Post and manually marked up one to a site like dropbox.com if you like. Screen pics of a manual navigation might help too.

I looked at Trade Limited, col A value of 02693994, in my test and had no parsed results returned either.

Here is the .xlsm that used to work.

https://www.dropbox.com/s/zw4jihn72agskp4/companieshouse.xlsm?dl=0

 

[Kyle123]

Have a look here, don't webscrape companies house, they offer a webservice you can use for this: UK Companies House API

 

[John_w]

Slightly odd code - initialising variables after they have been used!

Use the API and then you don't have to worry about the webpage changing.

For a quick fix, try changing:

name = doc.getElementsByTagName("li")(4).innerText  
  If Not doc.getElementsByTagName("li")(4) Is Nothing Then

to:

        If Not doc.getElementsByTagName("li")(5) Is Nothing Then
            name = doc.getElementsByTagName("li")(5).innerText

other changes may be needed.