Hi all! I am new to VBA and I have a list of urls in the A column, (ex. http://cgi.ebay.com/ebaymotors/Amer...BER-/131425495179?hash=item1e9991e88b&vxp=mtr), and I want to go to these urls and scrape the item specifics page into the adjacent columns. Thanks for any help!
Web scrape from a list of URLs
- Thread starter gswizzle
- Start date
I stated what I was looking for in the description of the post! I want to scrape the item specifics table from an eBay item listing! I have code that outputs error to every single column
, but this doesn't work properly, so I was looking for an alternate solution. That is all.
Code:
Global HTMLdoc As Object
Function GetElemText(ByRef Elem As Object, Optional ByRef ElemText As String) As String
If Elem Is Nothing Then ElemText = "~": Exit Function
' Is this element a text value?
If Elem.NodeType = 3 Then
' Separate text elements with a space character.
ElemText = ElemText & Elem.NodeValue & " "
Else
' Keep parsing - Element contains other non text elements.
For Each Elem In Elem.ChildNodes
Select Case UCase(Elem.NodeName)
Case Is = "BR": ElemText = vbLf
Case Is = "TD": If ElemText <> "" Then ElemText = ElemText & "|"
Case Is = "TR": ElemText = ElemText & vbLf
End Select
Call GetElemText(Elem, ElemText)
Next Elem
End If
GetElemText = ElemText
End Function
Function GetWebDocument(ByVal URL As String) As Variant
Dim Text As String
Set HTMLdoc = Nothing
With CreateObject("MSXML2.XMLHTTP")
.Open "GET", URL, True
.Send
While .readyState <> 4: DoEvents: Wend
If .Status <> 200 Then
GetWebDocument = "ERROR: " & .Status & " - " & .StatusResponse
Exit Function
End If
Text = .responseText
End With
Set HTMLdoc = CreateObject("htmlfile")
HTMLdoc.Write Text
HTMLdoc.Close
End Function
Sub GetData()
Dim Data As Variant
Dim n As Long
Dim oDiv As Object
Dim oTable As Object
Dim ret As Variant
Dim Rng As Range
Dim Text As String
Set Rng = Range("A2")
Do While Not IsEmpty(Rng)
ret = GetWebDocument(Rng)
' Check for a web page error.
If Not IsEmpty(ret) Then
Rng.Offset(0, 1).Value = ret
GoTo NextURL
End If
Set oDiv = HTMLdoc.getElementByID("vi-desc-maincntr")
' Locate the Item Specifics Table.
For n = 0 To oDiv.Children.Length - 1
If oDiv.Children(n).NodeType = 1 Then
If oDiv.Children(n).className = "itemAttr" Then
On Error Resume Next
Set oDiv = oDiv.Children(n)
Set oDiv = oDiv.Children(0)
Set oTable = oDiv.Children(2)
On Error GoTo 0
Exit For
End If
End If
Next n
' Check if Table exists.
If oTable Is Nothing Then
Rng.Offset(0, 1).Value = "Item Specifics were not found on this page."
GoTo NextURL
End If
c = 1
' Read the row data and output it to the worksheet.
For n = 0 To oTable.Rows.Length - 1
Text = ""
Text = GetElemText(oTable.Rows(n), Text)
' To avoid an error, check there is text to output.
If Text <> "" Then
Data = Split(Text, "|")
Rng.Offset(0, c).Resize(1, UBound(Data) + 1).Value = Data
c = c + UBound(Data) + 1
End If
Next n
NextURL:
Set Rng = Rng.Offset(1, 0)
Loop
End SubBump. I've changed my code
But now I run into error 91 "object variable or With block not set" on the Activesheet.Range("B2") line. What am I doing incorrectly? thanks!
Code:
Sub GetData()
Dim a As New htmldocument, x&, y&, z&
Dim URL As Variant
Dim Rng As Range
Set Rng = Range("A2")
Do While Not IsEmpty(Rng)
With CreateObject("WinHTTP.WinHTTPRequest.5.1")
.Open "GET", URL, False
.Send
a.body.innerHTML = .responseText
End With
z = 0
For y = 0 To a.getElementsByClassName("itemAttr")(0).Children(0).Children(1).Children(0).Children.Length - 2
For x = 1 To 3 Step 2
ActiveSheet.Range("B2").Offset(, z) = a.getElementsByClassName("itemAttr")(0).Children(0).Children(1).Children(0).Children(y).Children(x).innerText
z = z + 1
Next x
Next y
If a.getElementsByClassName("itemAttr")(0).Children(2) Is Nothing Then
Rng.Offset(0, 1).Value = "Could not find data."
GoTo NextURL
End If
NextURL:
Set Rng = Rng.Offset(1, 0)
Loop
End Sub