Updating web scraping code

Sharid · May 17, 2019

Hi

My following code at the bottom of this page, see below works fine, it extracts the data from a list of url that are on Sheet2 "URL LIST" and pastes them into Sheet1 Spider.

I now need it to extract two sets of data I need the URLs and emails address and the paste them in in Sheet1 “Spider” column A and B . However I can not work it out. .

These are the Classes I need the data from.

HTML:

<div class= "_5po3">
<div class ="_5aj7 _3-8j">
  <div class ="_4b17 _3-90 _a8s"></div>
<div class = "_4b19">
  <a href="mailto:sales@liftonbridgecarsales.com?__xts__=" id="u_jsonp_4_3">
    <div class="_50f4">sales@liftonbridgecarsales.com</div>
  </a>
</div>
<div class="_4bl7 _3-99"></div>
</div>
<div class="_5aj7 _3-8j">
  <div class ="_4b17 _3-90 _a8s"></div>
   <div class="_4b19">
      <a rel="noopener nofollow" href="https://l.facebook.com/l.php?u=http%3A%2F%2Fwww.liftonbridgecarsales.com%2F&h=AT1ASYg63SAoyrmb3JOMtCZAgZzweGbamq3V8ezYvC5mQsQf9lJcvi2oMskh3WSnXEAB7z0ZB9vPJp5Tt7lAtyRFWPhHQ086yx4yUZFAJpgAHCsYrq-xdgqSAIu9iLPzoliheoWXCASkTXZWAqpoYBkluhdkIBbZXqJycL_qVXIE4PzxDWC1hmrttQ9m8J5_60J9ZhK8IxEXoBe7c01mDyrszjZ_fscAPr46LbuEQBXT4impv4L-WQRIq0B4DvwQBQEF6TUDf9cCRodbtVLdwTQNvDvrcEMIdKFJo_7Mq-Bx4gL4DP5sBohVWuVq1U6HMejo6df2eMcgWBm_9IZWL7ja2yMW9G2abXYCsmF68UAz6oFEjxZrXSz4209wRFCz_QhEjGZ5W7pN1dkxnISHtK13Ib_ijrdb2DxEb0tD4RB9MHX2jCVDLoaE3SngnTmXm7k2MCRApz2W8Uy5dgiQfkWNA-lL70N1oS1dbAexxngPKXX5QS71-xk" target="_blank" data-lynx-mode="async" id="u_jsonp_4_4">
<div id="u_jsonp_4_5">
  <div id="u_jsonp_4_6">
  <div class="_50f4">http://www.liftonbridgecarsales.com</div>
</div>

MY CODE,
I have posted the original code, not my changes as I could not get it to work, most is fine, it runs a bit slow. The issue is highlighted in Blue

Code:

Private Sub CommandButton13_Click()

[COLOR=#008000]'URLS in Sheet2 called URL LIST[/COLOR]
    Dim LR      As Long
    Dim x       As Long
    Dim arr()   As Variant
    Dim wks     As Worksheet: Set wks = ThisWorkbook.Sheets("URL LIST")
    Dim ie      As Object: Set ie = CreateObject("InternetExplorer.Application")
    
Dim dd As Variant
On Error Resume Next
    Application.ScreenUpdating = False
    
   Dim Fr As Long
 With wks
        Fr = .Cells(.Rows.Count, 6).End(xlUp).Offset(1).Row
        LR = .Cells(.Rows.Count, 1).End(xlUp).Row
        .Cells(1, 12).Value = LR
        arr = .Range(.Cells(Fr, 1), .Cells(LR, 1)).Value
    End With
    
[COLOR=#008000]    ' open internet explorer[/COLOR]
    With ie
        .Visible = True
        Application.Wait Now + TimeValue("0:00:0")
        
        For x = LBound(arr, 1) To UBound(arr, 1)
            .navigate arr(x, 1)
            While .Busy Or .readyState <> 4: DoEvents: Wend
            
            On Error Resume Next
            
[COLOR=#008000]  'Change ClassName for data which need to be extracted out of webpage[/COLOR]
  Dim doc As HTMLDocument
     Set doc = ie.document
  [COLOR=#0000cd]   dd = doc.getElementsByClassName("_50f4")(0).Children(0).href[/COLOR]
On Error Resume Next

[COLOR=#008000]'Paste in this sheet, Sheet1 "Spider"[/COLOR]
[COLOR=#0000cd]Sheet1.Cells(Sheet1.Cells(Sheet1.Rows.Count, "A").End(xlUp).Row + 1, "A").Value = dd[/COLOR]
             
          [COLOR=#008000]  ' Put no1 in sheet2 "URL LIST "column F to indicate done[/COLOR]
  Sheets("URL LIST").Range("F" & Rows.Count).End(xlUp).Offset(1, 0).Value = 1
  
[COLOR=#008000]
'navigate links
       ' Next link[/COLOR]
 
[COLOR=#008000] 'Deletes duplicates in column A Sheet1[/COLOR]
            Columns(1).RemoveDuplicates Columns:=Array(1)
 
[COLOR=#008000] 'Count No1 in sheet2 Column F and show on userform[/COLOR]
With Worksheets("URL LIST")
    lastRow = .Cells(.Rows.Count, "F").End(xlUp).Row
    Sheets("URL LIST").Range("L2").Value = lastRow
    End With
             
            Call CommandButton9_Click
        Next x
        .Quit
    End With
   
End Sub

Also my code runs a bit slow, is there any way of speeding it up?

Sharid · May 26, 2019

Re: Need help on updating this code

Its ok i have got it sorted, just need to add your line on deleting duplicates,

Code:

Option Explicit
'VBE > Tools > References > HTML Object Library
Public Sub test()
    Dim ie As Object, ws As Worksheet, wsUrls As Worksheet, urls()
    Set ie = CreateObject("InternetExplorer.Application")
    Set ws = ThisWorkbook.Worksheets("Scraper")
    Set wsUrls = ThisWorkbook.Worksheets("Url List")

    With wsUrls
        urls = Application.Transpose(.Range("A2:A" & .Cells(.rows.Count, "A").End(xlUp).Row).Value)
    End With
    Dim results(), r As Long
    ReDim results(1 To UBound(urls), 1 To 2)

    With ie
        .Visible = True

        For r = LBound(urls) To UBound(urls)
            .Navigate2 urls(r)

            While .Busy Or .readyState < 4: DoEvents: Wend

            With .document

                Dim email As String, website As String, iconCssSelector As String
                'iconCssSelector for website icon in this instance
                iconCssSelector = "[src='https://static.xx.fbcdn.net/rsrc.php/v3/yV/r/EaDvTjOwxIV.png']"

                If ElementIsPresent(ie.document, "[href^=mailto]") Then
                    email = ie.document.querySelector("[href^=mailto]").innerText
                Else
                    email = "Not found"
                End If

                Dim parents As Object, sharedParentCssSelector As String, childOfSiblingCssSelector As String
                sharedParentCssSelector = "._5aj7" 'target parent of both icon and the website link
                childOfSiblingCssSelector = "._50f4" '< to target website address after finding right parent

                If ElementIsPresent(ie.document, iconCssSelector) _
        And ElementIsPresent(ie.document, sharedParentCssSelector) Then

                    Set parents = ie.document.querySelectorAll(sharedParentCssSelector) 'css selector used to allow for greater flexibility in element matching
                    website = GetText(ie.document, parents, iconCssSelector, childOfSiblingCssSelector)
                Else
                    website = "Not found"
                End If
            End With
            'Assumes headers already present
            Dim nextRow As Long
            results(r, 1) = email
            results(r, 2) = website
        Next
        .Quit
    End With
    nextRow = GetLastRow(ws, 1) + 1
    ws.Cells(nextRow, 1).Resize(UBound(results, 1), UBound(results, 2)) = results
End Sub

Public Function ElementIsPresent(ByVal document As HTMLDocument, ByVal cssSelector As String) As Boolean
    ElementIsPresent = document.querySelectorAll(cssSelector).length > 0
End Function

Public Function GetText(ByVal document As HTMLDocument, ByVal parents As Object, ByVal iconCssSelector As String, ByVal childOfSiblingCssSelector As String) As String
    'in this instance and with microsoft IE DOM you cannot select for parent of an element with pseudo class _
    of :has(>child); nor use :contains... instead pass expected parent selector, that houses _
    both the icon element for website and the website address itself, and loop all matches checking for website icon _
    if found use childOfSiblingCssSelector to extract
    Dim i As Long, html As HTMLDocument
    Set html = New HTMLDocument

    For i = 0 To parents.length - 1
        html.body.innerHTML = parents.item(i).innerHTML
        If ElementIsPresent(html, iconCssSelector) Then
            GetText = html.querySelector(childOfSiblingCssSelector).innerText
            Exit Function
        End If
    Next
    GetText = "Not found"
End Function

Public Function GetLastRow(ByVal ws As Worksheet, Optional ByVal columnNumber As Long = 1) As Long
    With ws
        GetLastRow = .Cells(.rows.Count, columnNumber).End(xlUp).Row
    End With
End Function

Updating web scraping code

Sharid

Well-known Member

Sharid

Well-known Member

Excel Facts

Similar threads

Forum statistics

Share this page

Updating web scraping code

Sharid

Well-known Member

Sharid

Well-known Member

Excel Facts

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock