Importing/scraping an website into excel - excel

I am trying to scrape some data from a database, and I have it pretty much set. I look in IE for a tab that has me logged in into the database, and paste the query link there through vba. But how do I extract the data that it returns from the IE tab and put that into an excel cell or array.
This is the code I have for opening my query:
Sub import()
Dim row As Integer
Dim strTargetFile As String
Dim wb As Workbook
Dim test As String
Dim ie As Object
Call Fill_Array_Cultivar
For row = 3 To 4
Sheets.Add.Name = Cultivar_Array(row, 1)
strTargetFile = "https://www3.wipo.int/pluto/user/jsp/select.jsp?fl=app_date%2Cden_info%2Cden_final&hl=false&json.nl=map&wt=json&type=upov&start=0&qi=3-nNCXQ6etEVv184O9nnd5yg%3D%3D&q=cc%3AIT%20AND%20latin_name%3A(zea%20mays)%20AND%20den_info%3A" & Trim(Cultivar_Array(row, 1)) & "&facet=false"
Set ie = GetIE("https://www3.wipo.int" & "*")
If Not ie Is Nothing Then
ie.navigate (strTargetFile)
Else
MsgBox "IE not found!"
End If
Next row
End Sub
And this is the appropriate function:
'Find an IE window with a matching (partial) URL
'Assumes no frames.
Function GetIE(sAddress As String) As Object
Dim objShell As Object, objShellWindows As Object, o As Object
Dim retVal As Object, sURL As String
Set retVal = Nothing
Set objShell = CreateObject("Shell.Application")
Set objShellWindows = objShell.Windows
'see if IE is already open
For Each o In objShellWindows
sURL = ""
On Error Resume Next
sURL = o.document.Location
On Error GoTo 0
If sURL <> "" Then
If sURL Like sAddress & "*" Then
Set retVal = o
Exit For
End If
End If
Next o
Set GetIE = retVal
End Function
What the website returns to me is a white page with a line of text. Here is an example:
{"response":{"start":0,"docs":[{"den_final":"Abacus","app_date":"1998-01-13T22:59:59Z"}],"numFound":1},"qi":"3-nNCXQ6etEVv184O9nnd5yg==","sv":"bswa2.wipo.int","lastUpdated":1436333633993}
PS. I also tried using the importxml function, it will import the website, but only an error page, as it does not recognize me as logged in.

I found the solution, which was fairly simple but hard to find.
I can just grab the ie.Document.body.innertext which is all the text I need.
See the code I updated below:
Sub import()
Dim row As Integer
Dim strTargetFile As String
Dim wb As Workbook
Dim test As String
Dim ie As Object
Dim pageText As String
Call Fill_Array_Cultivar
For row = 3 To 4
Sheets.Add.Name = Cultivar_Array(row, 1)
strTargetFile = "https://www3.wipo.int/pluto/user/jsp/select.jsp?fl=app_date%2Cden_info%2Cden_final&hl=false&json.nl=map&wt=json&type=upov&start=0&qi=3-nNCXQ6etEVv184O9nnd5yg%3D%3D&q=cc%3AIT%20AND%20latin_name%3A(zea%20mays)%20AND%20den_info%3A" & Trim(Cultivar_Array(row, 1)) & "&facet=false"
Set ie = GetIE("https://www3.wipo.int" & "*")
If Not ie Is Nothing Then
ie.navigate (strTargetFile)
Do Until ie.ReadyState = 4: DoEvents: Loop
pageText = ie.Document.body.innertext
ActiveSheet.Cells(1, 1) = pageText
pageText = Empty
Else
MsgBox "IE not found!"
End If
Next row
End Sub

Related

VBA to copy website data by putting details one by one

I have this website and i have been trying to create an function which collects ID Number from Col"A" and its Date of initiation in Col"B".
then adds the Sum of two boxes into 3rd one like below image.
after that it will go for the result it will be like
If the individual gets first dose then insert in Col"C" "1st Dose Done" If the individual gets second dose then insert in Col"D" "second dose done" if the individual has not taken both or single dose result will be empty.
then go for next until Col"A" used range. I have tried to create function but could not, Your help will be appreciated in this regards.
Option Explicit
Sub Newfunction()
Const Url$ = ""
Dim IdNumber As String, openDate As Date, LogData As Worksheet
Set LogData = ThisWorkbook.Worksheets("Sheet1")
IdNumber = LogData.Cells(2, "A").Value
openDate = LogData.Cells(2, "B").Value
Dim ie As Object
Set ie = CreateObject("InternetExplorer.Application")
With ie
.navigate Url
ieBusy ie
.Visible = True
Dim IDdata As Object, puttdate As Object, submitbut As String
Set IDdata = .document.getElementsByName("checkEligibilityForm:cnic")(0)
Set puttdate = .document.getElementsByName("checkEligibilityForm:issueDate_input")(0)
Set submitbut = .document.getElementsByClassName("submit__generated")(0).innerText
IDdata.Value = IdNumber
puttdate.Value = Format(openDate, "dd/mm/yyyy")
submitbut.Value = .document.getElementsByClassName("submit__input")(0)
Debug.Print .document.getElementsByClassName("submit__input")(0)
End With
End Sub
Sub ieBusy(ie As Object)
Do While ie.Busy Or ie.readyState < 4
DoEvents
Loop
End Sub
Try this code below - This should do the following:
Enter the CNIC
Enter the date
Answer the Captcha question
Click the button and the page should load.
As I can't proceed to the result page, I can't guarantee that it will produce the result page so please test it out with a proper data to see if it works. I have also tried to explain what each block of codes is doing in the comment.
Option Explicit
Sub Newfunction()
Const Url As String = "https://nims.nadra.gov.pk/nims/certificate"
Dim LogData As Worksheet
Set LogData = ThisWorkbook.Worksheets("Sheet1")
Dim IdNumber As String
Dim openDate As Date
IdNumber = LogData.Cells(2, "A").Value
openDate = LogData.Cells(2, "B").Value
Set LogData = Nothing
Dim ie As Object
Set ie = CreateObject("InternetExplorer.Application")
With ie
.navigate Url
Do While .Busy Or .readyState <> 4
DoEvents
Loop
.Visible = True
Dim ieDoc As Object
Set ieDoc = .Document
End With
'Enter the CNIC
Dim IDdata As Object
Set IDdata = ieDoc.getElementById("checkEligibilityForm:cnic")
If Not IDdata Is Nothing Then IDdata.Value = IdNumber
Set IDdata = Nothing
'Enter Date
Dim puttdate As Object
Set puttdate = ieDoc.getElementById("checkEligibilityForm:issueDate_input")
If Not puttdate Is Nothing Then puttdate.Value = Format(openDate, "dd-mm-yyyy")
Set puttdate = Nothing
'Answering the captcha question
'Split the innerText to string array to determine the equation
Dim captchaQns As Object
Set captchaQns = ieDoc.getElementsByClassName("submit__generated")(0)
If Not captchaQns Is Nothing Then
Dim mathEq() As String
mathEq = Split(captchaQns.innerText, " ")
Set captchaQns = Nothing
'mathEq(0) = first number
'mathEq(1) = math operator
'mathEq(2) = second number
If IsNumeric(mathEq(0)) Then
Dim firstNum As Long
firstNum = CLng(mathEq(0))
If IsNumeric(mathEq(2)) Then
Dim secondNum As Long
secondNum = CLng(mathEq(2))
'Select Case statement used here in case you encounter other form of math question (e.g. - X /), expand cases to cater for other scenario
Dim mathAnswer As Long
Select Case mathEq(1)
Case "+": mathAnswer = firstNum + secondNum
End Select
End If
End If
If mathAnswer <> 0 Then
'Enter the answer to the box
Dim captchaAns As Object
Set captchaAns = ieDoc.getElementsByClassName("submit__input")(0)
If Not captchaAns Is Nothing Then captchaAns.Value = mathAnswer
Set captchaAns = Nothing
'Get the submit button element, remove "disabled" attribute to allow clicking
Dim submitBtn As Object
Set submitBtn = ieDoc.getElementsByName("checkEligibilityForm:j_idt79")(0)
submitBtn.removeAttribute "disabled"
submitBtn.Click
Set submitBtn = Nothing
End If
End If
End Sub

Get URL of the image that is the first result in google images

I have multiple keywords in an excel file, I am looking for a way to get the image URL of the first google image result on another cell in this excel file,
For Example
if my cell A1 contains "tomato"
I want cell A2 to display "https://seeds-gallery.com/4963-large_default/novosadski-jabucar-tomato-450-seeds.jpg" which is the image URL of the first result that shows up on Google Images
Can someone please help me out
You could do that in VBA using something like the following;
Public Sub InsertPicturesFromWeb()
Dim IE As InternetExplorer
Dim HTMLdoc As HTMLDocument
Dim imgElements As IHTMLElementCollection
Dim imgElement As HTMLImg
Dim aElement As HTMLAnchorElement
Dim N As Integer, I As Integer
Dim Url As String, Url2 As String
Dim LastRow As Long
Dim M, sImageSearchString
LastRow = Range("A" & Rows.Count).End(xlUp).Row
For I = 1 To LastRow
Url = "https://www.google.co.in/search?q=" & Cells(I, 1) & "&source=lnms&tbm=isch&sa=X&rnd=1"
Set IE = New InternetExplorer
With IE
.Visible = False
.Navigate Url
Do Until .readyState = 4: DoEvents: Loop
Set HTMLdoc = .document
Set imgElements = HTMLdoc.getElementsByTagName("IMG")
N = 1
For Each imgElement In imgElements
If InStr(imgElement.src, sImageSearchString) Then
If imgElement.ParentNode.nodeName = "A" Then
Set aElement = imgElement.ParentNode
Url2 = imgElement.src
N = N + 1
End If
End If
Next
Call GetShapeFromWeb(Url2, Cells(I, 2))
IE.Quit
Set IE = Nothing
End With
Next I
End Sub
Sub GetShapeFromWeb(strShpUrl As String, rngTarget As Range)
With rngTarget.Parent
.Pictures.Insert strShpUrl
.Shapes(.Shapes.Count).Left = rngTarget.Left
.Shapes(.Shapes.Count).Top = rngTarget.Top
End With
End Sub

How to upload values to a website and select a button using Excel VBA

I am trying to automate the sending of SMSes from a company website but I do not know how to upload the message, the cellphone number and select the button to send the message.
Sub smssend()
Dim appIE As Object
Dim e As Object
Dim wb As Workbook
Dim ws As Worksheet
Dim cellno As String
Dim mess As String
Dim strPattern As String: strPattern = "^((?:\+27|0[0-9]{9}"
Dim regEx As New RegExp
Dim linecount As Long
linecount = 2
Set wb = Application.Workbooks("SMSmacro")
Set ws = wb.Worksheets("Sheet1")
Set appIE = CreateObject("internetexplorer.application")
With appIE
.navigate "http://cadde.abgza.co.za/SMS/CreateSMS/CreateSms"
Do While appIE.busy
DoEvents
Application.Wait (Now + TimeValue("0:00:03"))
Loop
.Visible = True
End With
Do While appIE.busy
DoEvents
Application.Wait (Now + TimeValue("0:00:03"))
Loop
Do While ws.Cells(linecount, 1) <> ""
cellno = ws.Cells(linecount, 1)
mess = ws.Cells(linecount, 2)
a = Len(mess)
If Len(mess) > 160 Then
ws.Cells(linecount, 4).Value = "Message Too Long"
GoTo nxt
End If
With regEx
If regEx.Test(cellno) Then
With appIE
Set e = appIE.document.getElementById("cellNumber")
e = cellno
End With
Else
ws.Cells(linecount, 3).Value = "Incorrect Cell Number"
End If
End With
nxt:
linecount = linecount + 1
Loop
End Sub
I've rewritten your code. Never use GoTo, except for error handling.
The three variables nodeCellNo, nodeMess and nodeSubBut are not mandatory. I have introduced them to make the code more comprehensible for you. Without variables you can access a node directly this way:
appIE.document.getElementById("cellNumber").Value = cellNo
I can't tell from your HTML code whether the change event of the textarea tag needs to be triggered to recognize the text of the message.
Please read the comments in the code carefully:
Sub SendSMS()
'If you have constant values use constants in your code
Const url As String = "http://cadde.abgza.co.za/SMS/CreateSMS/CreateSms"
Const strPattern As String = "^((?:\+27|0[0-9]{9}"
'If you use late binding, no Excel reference is required
'Advantage: The code runs immediately on every computer
'Disadvantage: No IntelliSense is available during programming
Dim appIE As Object
Dim nodeCellNo As Object
Dim nodeMess As Object
Dim nodeSubBut As Object
Dim wb As Workbook
Dim ws As Worksheet
Dim cellNo As String
Dim mess As String
Dim regEx As Object 'Changed to late binding
Dim currentRow As Long
'Initialize variables
currentRow = 2
Set wb = Application.Workbooks("SMSmacro.xlsm") 'Full name needed
Set ws = wb.Worksheets("Sheet1")
Set regEx = CreateObject("VBScript.RegExp")
Set appIE = CreateObject("internetexplorer.application")
'Use the following line if you are in an intranet and
'the IE lost connection to the remote server
'Set appIE = GetObject("new:{D5E8041D-920F-45e9-B8FB-B1DEB82C6E5E}")
'Load page to IE
appIE.Visible = True
appIE.navigate url
Do While appIE.busy: DoEvents: Loop
'The following line is only needed if the web page loads dynamic
'content after IE has reported that it is no longer busy
'The length of the break can be adjusted to your needs
Application.Wait (Now + TimeValue("0:00:03"))
'If the page looks like the SMS sending page after sending,
'the loop can start here. If another page is loaded, one
'could navigate again within the loop to the SMS URL. For
'many SMS I would set the loop further up and restart IE
'for each SMS. Unfortunately, if you navigate a lot in one
'instance of IE, it becomes unstable.
Do While ws.Cells(currentRow, 1) <> ""
cellNo = ws.Cells(currentRow, 1).Value
mess = ws.Cells(currentRow, 2).Value
If Len(mess) > 160 Then
ws.Cells(currentRow, 4).Value = "Message Too Long"
Else
If regEx.Test(cellNo) Then
'Insert cellphone number to html form
Set nodeCellNo = appIE.document.getElementById("cellNumber")
nodeCellNo.Value = cellNo
'Insert message to html form
'The textarea tag has no value attribute
'You can set the text by innertext to set it
'between the opening and the closing tectarea tag
Set nodeMess = appIE.document.getElementById("typedMessage")
nodeMess.innertext = mess
'Click submit button
Set nodeSubBut = appIE.document.getElementById("btnSend")
nodeSubBut.Click
'Wait to send the SMS
Application.Wait (Now + TimeValue("0:00:03"))
Else
ws.Cells(currentRow, 3).Value = "Incorrect Cell Number"
End If
End If
'Next SMS
currentRow = currentRow + 1
Loop
End Sub

How to use click function?

Everything works in my code except for the .click at the end.
It disables the button from clicking and it disables the operators ability to press 'enter' with the pasted text.
Only after I click in the text box and enter characters, can I hit enter (or click the button) to search.
Sub Part_Information()
'
' Part_Information Macro
'
' Keyboard Shortcut: Ctrl+a
'
ActiveCell.Select
Selection.Copy
Dim IE As Object
Dim MyURL As String
Dim objElement As Object
Dim objCollection As Object
Set IE = CreateObject("InternetExplorer.Application")
'''''''''''''''''''''''''''''''
'Switching to correct page
'If it can't be found, ends the sub
'If it is found, then switches to correct search bar and searches for information
'''''''''''''''''''''''''''''''
Set objShell = CreateObject("Shell.Application")
IE_count = objShell.Windows.Count
For x = 0 To (IE_count - 1)
On Error Resume Next ' sometimes more web pages are counted than are open
my_url = objShell.Windows(x).document.Location
my_title = objShell.Windows(x).document.Title
If my_title = "Parts Intelligence" Then
Set IE = objShell.Windows(x)
marker = 1
Exit For
End If
Next
If marker = 0 Then
MsgBox ("A matching webpage was NOT found")
Else
Set objCollection = IE.document.getElementsByTagName("input")
i = 0
While i < objCollection.Length
''''Change name (case sensitive)
If objCollection(i).class = "simple-search-text form-control short ng-valid ng-dirty ng-touched" Then
' Set text for search
objCollection(i).Value = ActiveCell.Value
Else
''''Change Type & Name (case sensitive)
If objCollection(i).class = "btn btn-icon" Then
objCollection(i).Click
' "Search" button is found
End If
End If
i = i + 1
Wend
End If
End Sub
This is from the webpage:
Search Button & Search Text Box:
Okay, so first things first. Do not create a new IE object if you are trying to find one that already exists. This will eventually start to bog down your computer having a hundred hidden Internet Explorers open in the background.
So, get rid of this
Set IE = CreateObject("InternetExplorer.Application")
'''''''''''''''''''''''''''''''
'Switching to correct page
'If it can't be found, ends the sub
'If it is found, then switches to correct search bar and searches for information
'''''''''''''''''''''''''''''''
Set objShell = CreateObject("Shell.Application")
IE_count = objShell.Windows.Count
For x = 0 To (IE_count - 1)
On Error Resume Next ' sometimes more web pages are counted than are open
my_url = objShell.Windows(x).document.Location
my_title = objShell.Windows(x).document.Title
If my_title = "Parts Intelligence" Then
Set IE = objShell.Windows(x)
marker = 1
Exit For
End If
Next
If marker = 0 Then
MsgBox ("A matching webpage was NOT found")
Else
and instead use something like this function - which will return the IE object that matches a URL and Title.
Dim IE As Object
Dim MyURL As String
Dim objElement As Object
Dim objCollection As Object
Set IE = getIE("https://myurl.com", "Parts Intelligence")
If IE Is Nothing Then
Rem: Add what happens if browser isn't found
End If
Function GetIE(sLocation As String, sDocTitle As String) As Object
Dim objShell As Object, objShellWindows As Object, o As Object
Dim sURL As String, sTitle As String
Dim RetVal As Object
Set RetVal = Nothing
Set objShell = CreateObject("shell.application")
Set objShellWindows = objShell.Windows
For Each o In objShellWindows
sURL = ""
On Error Resume Next
sURL = o.document.Location
sTitle = o.document.Title
On Error GoTo 0
If sURL Like "*" sLocation & "*" And sTitle Like sDocTitle & "*" Then
Set RetVal = o
Exit For
End If
Next o
Set GetIE = RetVal
End Function
Now, as for your issue. It's difficult to say exactly what is causing this problem without having access to the website in question. However, I had a very similar experience before and what allowed me to get past it was activating the textbox by code.
So, for your textbox, try using:
yourTextBoxObject.setActive
Then filling in the box. This should (hopefully) solve your problem with the button being disabled. With your code, it should look something like:
While i < objCollection.Length
''''Change name (case sensitive)
If objCollection(i).class = "simple-search-text form-control short ng-valid ng-dirty ng-touched" Then
' Set text for search
objCollection(i).setActive
objCollection(i).Value = ActiveCell.Value
Else
''''Change Type & Name (case sensitive)
If objCollection(i).class = "btn btn-icon" Then
objCollection(i).Click
' "Search" button is found
End If
End If
i = i + 1
Wend
Your full code:
Sub Part_Information()
'
' Part_Information Macro
'
' Keyboard Shortcut: Ctrl+a
'
ActiveCell.Select
Selection.Copy
Dim IE As Object
Dim MyURL As String
Dim objElement As Object
Dim objCollection As Object
Dim IE As Object
Dim MyURL As String
Dim objElement As Object
Dim objCollection As Object
Set IE = getIE("https://myurl.com", "Parts Intelligence")
If IE Is Nothing Then
Rem: Add what happens if browser isn't found
End If
Set objCollection = IE.document.getElementsByTagName("input")
i = 0
While i < objCollection.Length
''''Change name (case sensitive)
If objCollection(i).class = "simple-search-text form-control short ng-valid ng-dirty ng-touched" Then
' Set text for search
objCollection(i).Value = ActiveCell.Value
Else
''''Change Type & Name (case sensitive)
If objCollection(i).class = "btn btn-icon" Then
objCollection(i).Click
' "Search" button is found
End If
End If
i = i + 1
Wend
End Sub
Function GetIE(sLocation As String, sDocTitle As String) As Object
Dim objShell As Object, objShellWindows As Object, o As Object
Dim sURL As String, sTitle As String
Dim RetVal As Object
Set RetVal = Nothing
Set objShell = CreateObject("shell.application")
Set objShellWindows = objShell.Windows
For Each o In objShellWindows
sURL = ""
On Error Resume Next
sURL = o.document.Location
sTitle = o.document.Title
On Error GoTo 0
If sURL Like "*" sLocation & "*" And sTitle Like sDocTitle & "*" Then
Set RetVal = o
Exit For
End If
Next o
Set GetIE = RetVal
End Function

VBA procedure outputs a varying number of String Variables to be Declared and Reused

Here we have a procedure supplied to Codo by Mr Tim Williams which prints on the Immediate window something we really-really want. I made some mini modifications from the original copy and i have the comment-word MODIFICATION next to them
Sub MAGAZINE()
Dim IE As InternetExplorer ' MODIFICATION
Dim els, el, colDocLinks As New Collection
Dim lnk
Dim Ticker As String ' MODIFICATION
Set IE = New InternetExplorer 'MODIFICATION
IE.Visible = True
Ticker = Worksheets("Sheet1").Range("A1").Value 'MODIFICATION
loadpage IE, "https://www.sec.gov/cgi-bin/browse-edgar?" & _
"action=getcompany&CIK=" & Ticker & "&type=10-Q" & _ 'MODIFICATION by putting the Ticker String Variable and then Concatenate accordingly
"&dateb=&owner=exclude&count=20"
Set els = IE.Document.getelementsbytagname("a")
For Each el In els
If Trim(el.innertext) = "Documents" Then
colDocLinks.Add el.href
End If
Next el
For Each lnk In colDocLinks
loadpage IE, CStr(lnk)
For Each el In IE.Document.getelementsbytagname("a")
If el.href Like "*[0-9].xml" Then 'MODIFICATION
Debug.Print el.innertext, el.href
End If
Next el
Next lnk
End Sub
Sub loadpage(IE As Object, url As String)
IE.Navigate url
Do While IE.Busy Or IE.ReadyState <> READYSTATE_COMPLETE
DoEvents
Loop
End Sub
You can notice in the fourth modification/addition that a person can simply type the Stock Ticker on cell A1 and fire off the code
Ticker = Worksheets("Sheet1").Range("A1").Value 'MODIFICATION
Now the thing is that if we put different stock tickers we get different number of lines printed on the Immediate window.
For example by typing in cell A1 the ticker CRR we get 11 results
Now if we type in cell A1 the ticker MSFT we get 14 results
Now the crux of the issue is that these string values need to be inserted to the RIFLE macro and although i could assing the values i get from every loop iteration in String Variables what throws a monkey wrench in my mind is that the MAGAZINE macro as it is logical does not have an exact number of lines printed on the immediate window. You can see that actually in the preceding two pictures...
So how is it possible when MAGAZINE macro has an outcome of say 6 Lines; these to be assigned to 6 String Variables and not have 30 String Variables always declared wrecking havoc in memory and when the outcome is 14 Lines; these to be assigned to 14 String Variables.
How could this be adjusted on Running-Time so the Rifle always be loaded with correct number of rounds?
Because i will not stop there; then i have plans to plug these String Variables in the RIFLE macro provided by user2140261 and shown below...
Sub RIFLE()
Dim strXMLSite As String
Dim objXMLHTTP As MSXML2.XMLHTTP
Dim objXMLDoc As MSXML2.DOMDocument
Dim objXMLNodexbrl As MSXML2.IXMLDOMNode
Dim objXMLNodeDIIRSP As MSXML2.IXMLDOMNode
Set objXMLHTTP = New MSXML2.XMLHTTP
Set objXMLDoc = New MSXML2.DOMDocument
strXMLSite = "http://www.sec.gov/Archives/edgar/data/10795/000119312513456802/bdx-20130930.xml"
objXMLHTTP.Open "POST", strXMLSite, False
objXMLHTTP.send
objXMLDoc.LoadXML (objXMLHTTP.responseText)
Set objXMLNodexbrl = objXMLDoc.SelectSingleNode("xbrl")
Set objXMLNodeDIIRSP = objXMLNodexbrl.SelectSingleNode("us-gaap:DebtInstrumentInterestRateStatedPercentage")
Worksheets("Sheet1").Range("A1").Value = objXMLNodeDIIRSP.Text
End Sub
If you could plug this fluctuating number of String Values coming out of the MAGAZINE macro into String Variables in the RIFLE macro that would midwife the whole problem.
The RIFLE macro here has from it's original form the strXMLSite String Variabe.
UPDATE
I am currently trying to load it into an array and then unload it...
Here's one suggestion:
Sub MAGAZINE()
Dim IE As InternetExplorer ' MODIFICATION
Dim els, el, colDocLinks As New Collection
Dim lnk, res
Dim Ticker As String ' MODIFICATION
Dim colXMLPaths As New Collection '<<<EDIT
Set IE = New InternetExplorer 'MODIFICATION
IE.Visible = True
Ticker = Worksheets("Sheet1").Range("A1").Value 'MODIFICATION
LoadPage IE, "https://www.sec.gov/cgi-bin/browse-edgar?" & _
"action=getcompany&CIK=" & Ticker & "&type=10-Q" & _
"&dateb=&owner=exclude&count=20"
Set els = IE.Document.getelementsbytagname("a")
For Each el In els
If Trim(el.innertext) = "Documents" Then
colDocLinks.Add el.href
End If
Next el
For Each lnk In colDocLinks
LoadPage IE, CStr(lnk)
For Each el In IE.Document.getelementsbytagname("a")
If el.href Like "*[0-9].xml" Then
Debug.Print el.innertext, el.href
colXMLPaths.Add el.href '<<<EDIT
End If
Next el
Next lnk
'EDIT: ADDED
For Each lnk In colXMLPaths
res = RIFLE(CStr(lnk))
With Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
.NumberFormat = "#"
.Value = Ticker
.Offset(0, 1).Value = lnk
.Offset(0, 2).Value = res
End With
Next lnk
End Sub
Function RIFLE(sURL As String)
Dim strXMLSite As String
Dim objXMLHTTP As New MSXML2.XMLHTTP
Dim objXMLDoc As New MSXML2.DOMDocument
Dim objXMLNodexbrl As MSXML2.IXMLDOMNode
Dim objXMLNodeDIIRSP As MSXML2.IXMLDOMNode
RIFLE = "???"
objXMLHTTP.Open "GET", sURL, False '<<EDIT: GET not POST
objXMLHTTP.send
objXMLDoc.LoadXML (objXMLHTTP.responseText)
Set objXMLNodexbrl = objXMLDoc.SelectSingleNode("xbrl")
Set objXMLNodeDIIRSP = objXMLNodexbrl.SelectSingleNode _
("us-gaap:DebtInstrumentInterestRateStatedPercentage")
If Not objXMLNodeDIIRSP Is Nothing Then
RIFLE = objXMLNodeDIIRSP.Text
End If
End Function
Sub LoadPage(IE As Object, url As String)
IE.Navigate url
Do While IE.Busy Or IE.ReadyState <> READYSTATE_COMPLETE
DoEvents
Loop
End Sub

Resources