Option Explicit
Sub Get_That_Data()
Dim strHTML As String, strTitle As String, strImageUrl As String
Dim strH1 As String, strTextTemp As String, sURL As String
Dim LastRow As Long, i As Long
Const strMetaTag = "< meta property=""og:image"" content="""
Const strEnd = """ />"
Const strH1Tag = "< h1"
Const strH1End = ">"
Const strH1EndTag = "< /h1>"
'As you can see I don't use CreateObject("InternetExplorer.Application")
'Instead I use CreateObject("msxml2.xmlhttp")
With CreateObject("msxml2.xmlhttp")
LastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
'Loop through Column 1 from Activesheet
For i = 2 To LastRow
'I've just this sURL for testing:
'"http://www.metmuseum.org/art/collection/search/11122"
sURL = Cells(i, 1)
.Open "GET", sURL, False
.send
strHTML = .responseText
'To find the elements I don't use DOM methods
'but just search through the HTML.
'Get the titel
Cells(i, 2) = Mid(strHTML, InStr(strHTML, "<title>") + Len("<title>"), _
InStr(strHTML, "</title>") - InStr(strHTML, "<title>") - Len("</title>") + 1)
'Get the image url
strTextTemp = Mid(strHTML, InStr(1, strHTML, strMetaTag) + Len(strMetaTag))
Cells(i, 3) = Mid(strTextTemp, 1, InStr(strTextTemp, strEnd) - 1)
'Get the h1 header
strTextTemp = Mid(strHTML, InStr(InStr(1, strHTML, "h1"), strHTML, ">"))
Cells(i, 4) = Mid(strTextTemp, 2, InStr(strTextTemp, "</h1>") - 2)
'Autofit
Range(Cells(i, 1), Cells(i, 4)).Columns.AutoFit
Next i
End With
End Sub