a code to pull data from a website

Hi geniuses!
In a cell B2 of a worksheet, the user enters a "doi" value (that is like an ID for any publication!). I am trying to find a code that translates this "doi" to a citation that I can use in my thesis. after a long search, I found a website that does this for me. this website is "https://citation.crosscite.org/". you simply need to insert the doi value (the content of B2 in my worksheet) in the designated box, hit "format" and you will get the citation on the same webpage. is there a way to automate this in excel by a vba? I know that is called "web scraping" but I wasn't able to make it to work in my case. any help will be super appreciated! (ps, you will be helping a scientist who is trying to kick cancer's ***!)

Thanks a lot!

that is absolutely great!!!! I can't thank you enough!
however, I have a question. I want to adapt this amazing code to work even if my B column (doi entries) contains thousands of entries/some cells are even empty. also, can I activate the code automatically in real-time? so, whenever a user enters a new entry into the doi column, it searches only for the new entry & returns the results in a matching cell in column d for example?
thanks from all my heart!

is there also a way to ask the webpage to retrieve the citations with a different style than the default (apa) in the code? if there is a way, it would be super awesome! :D

Thanks for the kind words....

You may try the revised below code which works in range B3:B50000

You can define the range bigger or smaller to suit your needs.


You need to enter this in Sheet1 code module;

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("B3:B50000")) Is Nothing Then
        If Target <> "" Then
            Call GetReference(Target)
        End If
    End If
End Sub

And, enter the following code lines in a standart module;

Sub GetReference(myRng As Range)
    ' Haluk-25/09/2021
    ' https://excelhaluk.blogspot.com/
    ' ---------------------------------------
    '
    Dim HTTP As Object
    Dim URL As String
        
    Set HTTP = CreateObject("MSXML2.XMLHTTP")
    
    URL = "https://citation.crosscite.org/format?doi=" & URL_Encode(myRng) & "&style=apa&lang=en-US"
    HTTP.Open "GET", URL, False
    HTTP.send
    
    If HTTP.Status = 200 Then
        myRng.Offset(0, 1) = HTTP.responseText
    Else
        myRng.Offset(0, 1) = "Not Found!"
    End If
    
    Set HTTP = Nothing
End Sub
'
Function URL_Encode(strText)
    Dim objHtmlfile As Object
    
    If objHtmlfile Is Nothing Then
        Set objHtmlfile = CreateObject("HTMLFILE")
        objHtmlfile.parentWindow.execScript "function encode(s) {return encodeURIComponent(s);}", "JScript"
    End If
    
    URL_Encode = objHtmlfile.parentWindow.encode(strText)
End Function

Note: Sample workbook is also attached...

that is super great! I have to celebrate! thanks a looooot!

Hi Marc L,
Thanks for your answer. However, I didn't even know how to read let alone apply this super-advanced code! could you please, explain to me how I can apply it?
Thanks!

Originally Posted by blue_clouds_mountain

I didn't even know how to read let alone apply this super-advanced code! could you please, explain to me how I can apply it?

As it is at the same level than Haluk's initial code, no more advanced …
It was just an answer to your initial post to process all rows at once.
Thanks for the rep' !

According to the attachment a VBA demonstration for starters :

PHP Code: 

Sub Demo1()
        Dim V, R&
    With Range("B3:C" & [B1].CurrentRegion.Rows.Count)
        V = Application.Index(.Cells, Evaluate("ROW(1:" & .Rows.Count & ")"), [{2,1}])
    With CreateObject("WinHttp.WinHttpRequest.5.1")
            On Error Resume Next
        For R = 1 To UBound(V)
            If IsEmpty(V(R, 1)) And Not IsEmpty(V(R, 2)) Then
               .Open "GET", "https://citation.crosscite.org/format?style=apa&lang=en-US&doi=" & V(R, 2), False
               .setRequestHeader "DNT", "1"
               .send
                If .Status = 200 Then V(R, 1) = .responseText
            End If
        Next
    End With
       .Columns(2).Value2 = V
    End With
End Sub 


► Do you like it ? ► ► So thanks to click on bottom left star icon « ★ Add Reputation » ! ◄ ◄

You're welcome and thanks for the rep.