Get Webpage Title Text by URL Generated in MS Excel

[Anigito]

Dear Community,

I request your support with the following program (I have reviewed the posts in this forum, but could not find the right one for me).

The program should create URL, send request to webpage, get webpage title, process webpage title, write processed data to file, apply hyperlink.

The code has been working previously (i.e. last week), I have got the data, links were working, but now it seems like excel cannot access the webpage by defined URLs (see screenshot below; most likely, the webpage has some find of protection to filter out automated requests, I might be wrong). If I take the URL as text and put it to browser manually, the webpage opens normally.

View attachment 106389

Question:
I believe some code revision required (see the code below), but I cannot seem to pinpoint, what exactly is wrong.

What I have:
2019 MS Office
MS Edge Browser (however, I feel like it is not relevant, it is default browser)
References enabled: Microsoft HTML Object Library
NB! using this text as search query: "QE77S95CATXXH"

What I try to achieve:
Get webpage title by generated URL from Excel Table in loop and extract numeric information to MS Excel Table
Add Hyperlinks to cells with values (this one is OK)

What has been done:
Code, which looks like this:

Sub getKaina() ' populate price and stock cells, where available

Dim rngssemkt, cel As Range ' variables for target ranges on KA sheets
Dim wsn As String ' sheet name
Dim lstrow As Long ' the last row on KA sheet
Dim titleLT As String ' for html title from web page
Dim objHttp As Object

With Application
    .ScreenUpdating = False
End With

wsn = ActiveSheet.Range("R1").Text
lstrow = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row

With ThisWorkbook.Worksheets(wsn)
    Set rngssemkt = .Range("J18:J" & lstrow)
End With

rngssemkt.ClearContents

For Each cel In rngssemkt.Cells
    On Error Resume Next
    If Len(ThisWorkbook.ActiveSheet.Range("G" & cel.Row).Text) = 0 Then
        GoTo NoModelG
    Else
        With CreateObject("MSXML2.ServerXMLHTTP")
            .Open "GET", "https://www.kaina24.lt/search?q=" & ThisWorkbook.ActiveSheet.Range("G" & cel.Row), False
            .send
            titleLT = .responseText
            If .readyState = 4 And .Status = 200 And InStr(1, titleLT, "<title>") Then
                titleLT = Val(Mid(titleLT, InStr(1, titleLT, "nuo") + 4, InStr(1, titleLT, "€") - InStr(1, titleLT, "nuo") - 2))
            Else
                titleLT = "no access"
            End If
        End With
    
        With cel
            .Hyperlinks.Add Anchor:=cel, _
                Address:="https://www.kaina24.lt/search?q=" & ThisWorkbook.ActiveSheet.Range("G" & cel.Row), _
                ScreenTip:="Follow this link to see models >> ", _
                TextToDisplay:=titleLT
            .NumberFormat = "#,##0.0_);(#,##0.0);"
            .Font.Size = 8
            .Font.Underline = False
        End With
    End If
NoModelG:
Next

With Application
    .ScreenUpdating = True
End With

MsgBox _
    "The Lowest online market offer taken from www.kaina24.lt price aggregation website", vbOKOnly, "UPDATED: @" & Now()

End Sub

 

[Anigito]

Dear Community,

I request your support with the following program (I have reviewed the posts in this forum, but could not find the right one for me).

The program should create URL, send request to webpage, get webpage title, process webpage title, write processed data to file, apply hyperlink.

The code has been working previously (i.e. last week), I have got the data, links were working, but now it seems like excel cannot access the webpage by defined URLs (see screenshot below; most likely, the webpage has some find of protection to filter out automated requests, I might be wrong). If I take the URL as text and put it to browser manually, the webpage opens normally.

View attachment 106389

Question:
I believe some code revision required (see the code below), but I cannot seem to pinpoint, what exactly is wrong.

What I have:
2019 MS Office
MS Edge Browser (however, I feel like it is not relevant, it is default browser)
References enabled: Microsoft HTML Object Library
NB! using this text as search query: "QE77S95CATXXH"

What I try to achieve:
Get webpage title by generated URL from Excel Table in loop and extract numeric information to MS Excel Table
Add Hyperlinks to cells with values (this one is OK)

What has been done:
Code, which looks like this:

Sub getKaina() ' populate price and stock cells, where available

Dim rngssemkt, cel As Range ' variables for target ranges on KA sheets
Dim wsn As String ' sheet name
Dim lstrow As Long ' the last row on KA sheet
Dim titleLT As String ' for html title from web page
Dim objHttp As Object

With Application
    .ScreenUpdating = False
End With

wsn = ActiveSheet.Range("R1").Text
lstrow = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row

With ThisWorkbook.Worksheets(wsn)
    Set rngssemkt = .Range("J18:J" & lstrow)
End With

rngssemkt.ClearContents

For Each cel In rngssemkt.Cells
    On Error Resume Next
    If Len(ThisWorkbook.ActiveSheet.Range("G" & cel.Row).Text) = 0 Then
        GoTo NoModelG
    Else
        With CreateObject("MSXML2.ServerXMLHTTP")
            .Open "GET", "https://www.kaina24.lt/search?q=" & ThisWorkbook.ActiveSheet.Range("G" & cel.Row), False
            .send
            titleLT = .responseText
            If .readyState = 4 And .Status = 200 And InStr(1, titleLT, "<title>") Then
                titleLT = Val(Mid(titleLT, InStr(1, titleLT, "nuo") + 4, InStr(1, titleLT, "€") - InStr(1, titleLT, "nuo") - 2))
            Else
                titleLT = "no access"
            End If
        End With
   
        With cel
            .Hyperlinks.Add Anchor:=cel, _
                Address:="https://www.kaina24.lt/search?q=" & ThisWorkbook.ActiveSheet.Range("G" & cel.Row), _
                ScreenTip:="Follow this link to see models >> ", _
                TextToDisplay:=titleLT
            .NumberFormat = "#,##0.0_);(#,##0.0);"
            .Font.Size = 8
            .Font.Underline = False
        End With
    End If
NoModelG:
Next

With Application
    .ScreenUpdating = True
End With

MsgBox _
    "The Lowest online market offer taken from www.kaina24.lt price aggregation website", vbOKOnly, "UPDATED: @" & Now()

End Sub

I have tried and failed to solve the issue with the following article:

1. Reddit Post with the same Issue
2. Microsoft Post referenced as solution to the above