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 19, 2019

Re: Need help on updating this code

Hi

I hope someone can help, I have got my code working, just 1 issue. I need it to put the row data in column A and B. Currently it can only Do A. THE REST OF THE CODE IS FINE

The data it has to get is highlighed in Blue
The issue in the code is highlighted in Red

Code:

Private Sub fbStart_Click()

[COLOR=#008000]'Set sheet2 URL List and open Internet Explorer[/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, 5).Value = LR
        arr = .Range(.Cells(Fr, 1), .Cells(LR, 1)).Value
    End With
    
[COLOR=#008000]'Show Internet Explorer and add delay in seconds if needed[/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]'Variable for document or data which need to be extracted out of webpage, change innertext number if same class used[/COLOR]
  Dim doc As HTMLDocument
     Set doc = ie.document

[COLOR=#0000cd]dd = doc.getElementsByClassName("_50f4")(2).innerText
dd = doc.getElementsByClassName("_50f4")(3).innerText  [/COLOR]

On Error Resume Next

[COLOR=#008000]'Paste in this sheet[/COLOR]
 [COLOR=#ff0000]Sheet1.Cells(Sheet1.Cells(Sheet1.Rows.Count, "A").End(xlUp).Row + 1, "A").Value = dd[/COLOR]
   
[COLOR=#008000]' Put no1 in sheet2 column B[/COLOR]
  Sheets("Url List").Range("B" & Rows.Count).End(xlUp).Offset(1, 0).Value = 1
  
 
[COLOR=#008000] 'Deletes duplicates in column A Sheet1[/COLOR]
    Columns(1).RemoveDuplicates Columns:=Array(1)
 
[COLOR=#008000] 'Count No1 in sheet2 Column B[/COLOR]
With Worksheets("Url List")
    lastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
    Sheets("Url List").Range("B1").Value = lastRow
    End With
             
            Call Autoclick_Click
        Next x
        .Quit
    End With

[COLOR=#008000]'Hide FaceBook Scraper Form[/COLOR]
   ScraperForm.Hide
  
End Sub

Domenic · May 19, 2019

Re: Need help on updating this code

First, declare dd as a two-element String array instead...

Code:

Dim dd(1 To 2) As String

Then you can retrieve your data this way...

Code:

    dd(1) = doc.getElementsByClassName("_50f4")(2).innerText
    dd(2) = doc.getElementsByClassName("_50f4")(3).innerText

And then you can transfer the values to your worksheet...

Code:

    With Sheet1
        .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Resize(, 2).Value = dd
    End With

Hope this helps!

Sharid · May 19, 2019

Re: Need help on updating this code

Thanks Dominic I did manage fix it in the end myself, as shown below in orange. However I will input your changes as they look a lot better

I have highlighted changes in orange

Code:

Private Sub fbStart_Click()
'Set sheet2 URL List and open Internet Explorer
    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
[COLOR=#ff8c00]Dim dd1 As Variant[/COLOR]
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, 5).Value = lr
        arr = .Range(.Cells(Fr, 1), .Cells(lr, 1)).Value
    End With
    
[COLOR=#008000]'Show Internet Explorer and add delay in seconds if needed[/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]'Variable for document or data which need to be extracted out of webpage, change innertext number if same class used[/COLOR]
  Dim doc As HTMLDocument
     Set doc = ie.document

dd = doc.getElementsByClassName("_50f4")(2).innerText
[COLOR=#ff8c00]dd1[/COLOR] = doc.getElementsByClassName("_50f4")(3).innerText

On Error Resume Next

[COLOR=#008000]'Paste in this sheet[/COLOR]
 Sheet1.Cells(Sheet1.Cells(Sheet1.Rows.Count, "A").End(xlUp).Row + 1, "A").Value = dd
 [COLOR=#ff8c00] Sheet1.Cells(Sheet1.Cells(Sheet1.Rows.Count, "B").End(xlUp).Row + 1, "B").Value = dd1[/COLOR]
  
' Put no1 in sheet2 column B
  Sheets("Url List").Range("B" & Rows.Count).End(xlUp).Offset(1, 0).Value = 1
  
 [COLOR=#008000]
 'Deletes duplicates in column A Sheet1[/COLOR]
    Columns(1).RemoveDuplicates Columns:=Array(1)
  [COLOR=#ff8c00]  Columns(2).RemoveDuplicates Columns:=Array(1)[/COLOR]
  
[COLOR=#008000] 'Count No1 in sheet2 Column B[/COLOR]
With Worksheets("Url List")
    Lastrow = .Cells(.Rows.Count, "B").End(xlUp).Row
    Sheets("Url List").Range("B1").Value = Lastrow
    End With
             
            Call Autoclick_Click
        Next x
       .Quit
    End With

[COLOR=#008000]'Hide FaceBook Scraper Form[/COLOR]
   ScraperForm.Hide
   
End Sub

Sharid · May 19, 2019

Re: Need help on updating this code

Finale code with Domenic code added, shown in red

Code:

Private Sub fbStart_Click()
[COLOR=#008000]'Set sheet2 URL List and open Internet Explorer[/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")
    
[COLOR=#ff0000]Dim dd(1 To 2) As String[/COLOR]
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, 5).Value = lr
        arr = .Range(.Cells(Fr, 1), .Cells(lr, 1)).Value
    End With
 [COLOR=#008000]   
'Show Internet Explorer and add delay in seconds if needed[/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]
'Variable for document or data which need to be extracted out of webpage, change innertext number if same class used[/COLOR]
  Dim doc As HTMLDocument
     Set doc = ie.document

[COLOR=#ff0000]dd(1) = doc.getElementsByClassName("_50f4")(2).innerText
dd(2) = doc.getElementsByClassName("_50f4")(3).innerText[/COLOR]

On Error Resume Next

[COLOR=#008000]'Paste in this sheet[/COLOR]
[COLOR=#ff0000]With Sheet1
        .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Resize(, 2).Value = dd
    End With[/COLOR]
  [COLOR=#008000]
' Put no1 in sheet2 column B[/COLOR]
  Sheets("Url List").Range("B" & Rows.Count).End(xlUp).Offset(1, 0).Value = 1
  
 
[COLOR=#008000] 'Deletes duplicates in column A Sheet1[/COLOR]
    Columns(1).RemoveDuplicates Columns:=Array(1)
    Columns(2).RemoveDuplicates Columns:=Array(1)
  
[COLOR=#008000] 'Count No1 in sheet2 Column B[/COLOR]
With Worksheets("Url List")
    Lastrow = .Cells(.Rows.Count, "B").End(xlUp).Row
    Sheets("Url List").Range("B1").Value = Lastrow
    End With
             
            Call Autoclick_Click
        Next x
       .Quit
    End With

[COLOR=#008000]'Hide FaceBook Scraper Form[/COLOR]
   ScraperForm.Hide
   
End Sub

Domenic · May 19, 2019

Re: Need help on updating this code

That's great, glad you've got it working, one way or another.

Sharid · May 25, 2019

Re: Need help on updating this code

Hi

I though this was sorted, however it has kicked up another few problems and it is way out of my depth. I have been trying for days to fix it, but with no luck

The problems NOW are as such

1) Although it extracts the data, it does not extract JUST emails and URLs, but anything in that class
2) Data is mixed, so email mixed with other data can be in columns A or B when Emails should be in A and URls in B
3) I think my delete duplicates is deleting duplicates in columns when it should be deleting DUPLICATE ROWS

I found this for extracting just emails, hope

YouTube Vid - https://www.youtube.com/watch?v=Z6_yGZ-w2Q8

Code Urls for extracting emails - http://www.exceltrainingvideos.com/automate-email-extraction-from-website-using-excel-vba/

Code Urls for extracting Urls - http://www.exceltrainingvideos.com/automate-scraping-of-hyperlinks-from-web-pages-using-excel-vba/

How the code works -

On Sheet2 "URL List" I have a list of URLs, the code runs through this and places the results onto Sheet1 "Scraper". and deletes any duplicates. My code is only supposed to scraper email and URLs and place them in Column A + B in the NEXT BLANK ROW.

I have tried to fix the problem but it is out of my scope. i am hoping someone can help

The code is below the. As stated above the code works fine apart from the code in RED, this is what the problem most likley is. The orange code is the delete options which may also be incorrect as DUPLICATE ROWS should be deleted and not Duplicate values in cells.

This is a FACEBOOK SCRAPER and scrapes the "about " pages urls here is a link https://www.facebook.com/pg/SalemFor...rnal%5Blink%5D

My Code

Code:

Private Sub fbStart_Click()
[COLOR=#008000]'Set sheet2 URL List and open Internet Explorer[/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")
    
[COLOR=#ff0000]Dim dd(1 To 2) As String[/COLOR]
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, 5).Value = lr
        arr = .Range(.Cells(Fr, 1), .Cells(lr, 1)).Value
    End With
 [COLOR=#008000]   
'Show Internet Explorer and add delay in seconds if needed[/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]
'Variable for document or data which need to be extracted out of webpage, change innertext number if same class used[/COLOR]
  Dim doc As HTMLDocument
     Set doc = ie.document

[COLOR=#ff0000]dd(1) = doc.getElementsByClassName("_50f4")(2).innerText
dd(2) = doc.getElementsByClassName("_50f4")(3).innerText[/COLOR]

On Error Resume Next

[COLOR=#008000]'Paste in this sheet[/COLOR]
[COLOR=#ff0000]With Sheet1
        .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Resize(, 2).Value = dd
    End With[/COLOR]
  [COLOR=#008000]
' Put no1 in sheet2 column B[/COLOR]
  Sheets("Url List").Range("B" & Rows.Count).End(xlUp).Offset(1, 0).Value = 1
  
 
[COLOR=#008000] 'Deletes duplicates in column A Sheet1[/COLOR]
    [COLOR=#ff8c00]Columns(1).RemoveDuplicates Columns:=Array(1)
    Columns(2).RemoveDuplicates Columns:=Array(1)[/COLOR]
  
[COLOR=#008000] 'Count No1 in sheet2 Column B[/COLOR]
With Worksheets("Url List")
    Lastrow = .Cells(.Rows.Count, "B").End(xlUp).Row
    Sheets("Url List").Range("B1").Value = Lastrow
    End With
             
            Call Autoclick_Click
        Next x
       .Quit
    End With

[COLOR=#008000]'Hide FaceBook Scraper Form[/COLOR]
   ScraperForm.Hide
   
End Sub

Domenic · May 25, 2019

Re: Need help on updating this code

dd(1) = doc.getElementsByClassName("_50f4")(2).innerText
dd(2) = doc.getElementsByClassName("_50f4")(3).innerText

I only looked at that one Facebook link you provided, and it looks like the above returns both the email and url.

Columns(1).RemoveDuplicates Columns:=Array(1)
Columns(2).RemoveDuplicates Columns:=Array(1)

To remove duplicates with the two columns, try replacing the above with the following...

Code:

Sheet1.Columns("A:B").RemoveDuplicates Columns:=Array(1, 2)

Sharid · May 26, 2019

Re: Need help on updating this code

Hi Domenic

Thanks for your reply.

I only looked at that one Facebook link you provided, and it looks like the above returns both the email and url.

I also noticed this, it is why I want to drill down further, so the search is via Div + ID e.g. div (a) ID xxxx.

I have attached a this link which shows the Tags, ID, Class and inner text. I am hoping you or someone else can help. The rows in Yellow seem to be my best bet, see link for more info

Please see atatched - https://app.box.com/s/s4p7eb1n3nrmj7hwkw237ijrvrrrfki3

Also not sure what has happened to my first post, i looked at it today and there is a lot of this

<!--[if gte mso 9]><xml> <w:WordDocument> <w:View>Normal</w:View> <w:Zoom>0</w:Zoom> <w:TrackMoves/> <w:TrackFormatting/> <w:PunctuationKerning/> <w:ValidateAgainstSchemas/> <w:SaveIfXMLInvalid>false</w:SaveIfXMLInvalid> <w:IgnoreMixedContent>false</w:IgnoreMixedContent> <w:AlwaysShowPlaceholderText>false</w:AlwaysShowPlaceholderText> <w:DoNotPromoteQF/> <w:LidThemeOther>EN-GB</w:LidThemeOther> <w:LidThemeAsian>X-NONE</w:LidThemeAsian> <w:LidThemeComplexScript>X-NONE</w:LidThemeComplexScript> <w:Compatibility> <w:BreakWrappedTables/> <w:SnapToGridInCell/> <w:WrapTextWithPunct/> <w:UseAsianBreakRules/> <w:DontGrowAutofit/>

This was not there yesterday, if anyone can let me know, I would be grateful.

Domenic · May 26, 2019

Re: Need help on updating this code

Sorry, but that image you've posted only confuses things. Which URL do you want to get information from? And, specifically, which information on that page do you want to get? If you have and ID, though, you can use getElementById...

Code:

doc.getElementById("u_0_p").innerText

Updating web scraping code

Sharid

Well-known Member

Excel Facts

Sharid

Well-known Member

Domenic

MrExcel MVP

Sharid

Well-known Member

Sharid

Well-known Member

Domenic

MrExcel MVP

Sharid

Well-known Member

Domenic

MrExcel MVP

Sharid

Well-known Member

Domenic

MrExcel MVP

Similar threads

Forum statistics

Share this page

Updating web scraping code

Well-known Member

Excel Facts

Well-known Member

MrExcel MVP

Well-known Member

Well-known Member

MrExcel MVP

Well-known Member

MrExcel MVP

Well-known Member

MrExcel MVP

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