title: Email scraper from a list of urls
body: <p><strong>What I am trying to build</strong></p>
  <p>In Sheet1 column A row2 down to x amount of rows, there will be a list of website URLs. I need the code to go through the urls and find the phone numbers and emails and place them in column B + C next to the urls, if nothing is found place a hyphen in the cell.</p>
  <p>I have almost got this working. The code loops through a list of URLS in Sheet1 column A and pulls the phone numbers and emails, places them into column B and C. I just have 3 problems with the current code i wrote, these are stated below Problem 3 might be a simple fix.</p>
  <p><strong>THE NEW CODE</strong></p>
  <pre><code>Private Sub CommandButton1_Click()
  ' Run main code
  Dim wb As Workbook
  Dim wsSheet As Worksheet, links As Variant, IE As Object, link As Variant
  Dim rw As Long
  Dim html As New HTMLDocument
  Dim regxp As New RegExp, post As Object, phone_list As Object, email_list As Object
  
  'SHEET1 as sheet with URL
      Set wb = ThisWorkbook
      Set wsSheet = wb.Sheets(&quot;Sheet1&quot;)
  
      'Set IE = InternetExplorer
      Set IE = CreateObject(&quot;InternetExplorer.Application&quot;)
  
      rw = wsSheet.Cells(wsSheet.Rows.Count, &quot;A&quot;).End(xlUp).Row
      links = wsSheet.Range(&quot;A2:A&quot; &amp; rw)
  
      'IE Open Time per page 4sec and check links on Sheet2 Column A
      With IE
         .Visible = True
         Application.Wait (Now + TimeValue(&quot;00:00:04&quot;))
  
         For Each link In links
             .navigate (link)
             While .Busy Or .readyState &lt;&gt; 4: DoEvents: Wend
  
  Set html = .document
  
  'Application.Wait (Now + TimeValue(&quot;00:00:04&quot;))
    With regxp
          .Pattern = &quot;(?:\+1)?(?:\+[0-9])?\(?([0-9]{3})\)?[-. ]?([0-9]{3})[-. ]?([0-9]{4})&quot;
          Set phone_list = .Execute(html.body.innerHTML)
          .Pattern = &quot;[a-zA-Z0-9_.+-]+@[a-zA-Z0-9-]+\.[a-zA-Z0-9-.]+&quot;
          Set email_list = .Execute(html.body.innerHTML)
      End With
     
      Sheet1.Cells(Sheet1.Cells(Sheet1.Rows.Count, &quot;B&quot;).End(xlUp).Row + 1, &quot;B&quot;).Value = phone_list(0)
      Sheet1.Cells(Sheet1.Cells(Sheet1.Rows.Count, &quot;C&quot;).End(xlUp).Row + 1, &quot;C&quot;).Value = email_list(0)
   ''''################################ I TRIED TO FIX THE PROBLEM WITH THIS  #########################
   '''' ############################### TO PLACE A HYPHEN IF NOTHING IS FOUND #########################
  ''''      If regxp Is Nothing Then
  ''''            wsSheet.Cells(Sheet1.Cells(Sheet1.Rows.Count, &quot;B&quot;).End(xlUp).Row + 1, &quot;B&quot;).Value = phone_list()
  ''''        Else
  ''''             wsSheet.Cells(Sheet1.Cells(Sheet1.Rows.Count, &quot;B&quot;).End(xlUp).Row + 1, &quot;B&quot;).Value = phone_list(0)
  ''''        End If
  ''''
  ''''        If regxp Is Nothing Then
  ''''            wsSheet.Cells(Sheet1.Cells(Sheet1.Rows.Count, &quot;C&quot;).End(xlUp).Row + 1, &quot;C&quot;).Value = email_list()
  ''''        Else
  ''''            wsSheet.Cells(Sheet1.Cells(Sheet1.Rows.Count, &quot;C&quot;).End(xlUp).Row + 1, &quot;C&quot;).Value = email_list(0)
  ''''        End If
  ''''################################ I TRIED TO FIX THE PROBLEM WITH THIS  #########################
  ''''################################################################################################
  
  'navigate links
        Next link
  
  'Close IE Browser
      .Quit
      End With
  
      Set IE = Nothing
  End Sub
  
  </code></pre>
  <p><strong>Problem 1</strong></p>
  <p>If there is no item to extract then the code does not go to the next url, for some reason it just stay on that page, or I get an error message. <strong>e.g</strong> website has phone number but no email the page will not navigate to the next url. <em>I tried to fix this with an <strong>IF statement</strong> but could not get it to work.</em>. <strong>What it should do</strong> If there is nothing to extract go to the next urls in column A</p>
  <p><a href="https://i.stack.imgur.com/zxtXb.png" rel="nofollow noreferrer"><img src="https://i.stack.imgur.com/zxtXb.png" alt="VBA error message" /></a></p>
  <p><a href="https://i.stack.imgur.com/iR60K.png" rel="nofollow noreferrer"><img src="https://i.stack.imgur.com/iR60K.png" alt="VBA Code line error" /></a></p>
  <p><strong>Problem 2</strong></p>
  <p>If the website has an invalid security certificate or the url is DEAD then the code does not navigate to the next url, it waits for a user input. If I click &quot;NO&quot; to state I do not wish to to navigate to this site the code crashes. <em>If the certificate is invalid or url is DEAD then it should move to the next url, so if site has not loaded in X amount of time move to the next url.</em> Not sure if this could also be used for problem1</p>
  <p><strong>I think I need something like this, but can't work it out with my code <a href="https://www.mrexcel.com/board/threads/vba-ignore-url-webscrape-if-link-doesnt-work.981732/" rel="nofollow noreferrer">Mr Excel</a></strong></p>
  <p><strong>Problem 3</strong></p>
  <p>This might just be an excel column formating issue unless I have have got the phone number expression wrong in the code. As you can see the phone numbers are not showing correct. I am not sure if excel is clearing an &quot;0&quot; and that is why the numbers are wrong or the phone number expression is wrong.</p>
  <p><a href="https://i.stack.imgur.com/Buqhp.png" rel="nofollow noreferrer"><img src="https://i.stack.imgur.com/Buqhp.png" alt="Phone Numbers" /></a></p>
  <p>Thanks for having a look Please could sombody help me out on anyone of the three issues. As aways THANKS in advance.</p>
  <p><strong>UPDATED TODAY 24/7/2020 AT 12:56 UK TIME</strong></p>
  <p>I have added a better Regxp for finding phone numbers, since posting PROBLEM 3, it has improved a bit <code>.Pattern = &quot;(?:\+1)?(?:\+[0-9])?\(?([0-9]{3})\)?[-. ]?([0-9]{3})[-. ]?([0-9]{4})&quot;</code> it is still however clipping some digits of the numbers, see image below, numbers in green where found and last digit is missing</p>
  <p><a href="https://i.stack.imgur.com/h7X5T.png" rel="nofollow noreferrer"><img src="https://i.stack.imgur.com/h7X5T.png" alt="Phone missing digit" /></a></p>
  <p><strong>Also</strong> Posted on Mr Excel <a href="https://www.mrexcel.com/board/threads/updating-a-code.1140235/#post-5522715" rel="nofollow noreferrer">Mr Excel</a>.</p>
  <p><strong>####### Added Today Thursday 30th July 2020 4:00pm Uk time ########</strong></p>
  <p>I am trying an If statement so If Nothing is found then place a hyphen, see below</p>
  <pre><code>If email_list Is Nothing Then
  'On Error Resume Next
  wsSheet.Cells(Sheet1.Cells(Sheet1.Rows.Count, &quot;c&quot;).End(xlUp).Row + 1, &quot;c&quot;).Value = &quot;-&quot;
  Else
  On Error Resume Next
  wsSheet.Cells(Sheet1.Cells(Sheet1.Rows.Count, &quot;c&quot;).End(xlUp).Row + 1, &quot;c&quot;).Value = email_list(0)
  End If
  End With
  
  </code></pre>
  <p>However I can Not get it to work, the <strong>On Error Resume Next</strong> allows me to move to the next url and gets rid of the first error message.</p>
  <p><strong>The emails NOW pull off as such,</strong> I have colour coded them for easy viewing. As you can see from the colours they are <strong>NOT</strong> <em>next to the correct urls</em>, This is why I was trying to place an hyphen in the cell at least then that cell would be poplulated an the date would go into the next blank cell, thus keeping everything in line.
  <a href="https://i.stack.imgur.com/bABNg.png" rel="nofollow noreferrer"><img src="https://i.stack.imgur.com/bABNg.png" alt="email image" /></a></p>
  <p><strong>############## Updated Today FRIDAY 31st JULY 2020 1.26PM UK time</strong></p>
  <p>I have fixed the problem with data <strong>NOT</strong> going into the right place, By uking the IF statement code. So now Problems 1 and 2 seem fine. Only problem 3 remains, which I though would be a simple fix LOL.</p>
  <p>The problem was this</p>
  <pre><code>If regxp Is Nothing Then
  </code></pre>
  <p>It should have been</p>
  <pre><code>If Phone_List (0) Is Nothing Then
  </code></pre>
  <p>And</p>
  <pre><code>If Email_List (0) Is Nothing Then
  </code></pre>
  <p><a href="https://i.stack.imgur.com/NmGAV.png" rel="nofollow noreferrer"><img src="https://i.stack.imgur.com/NmGAV.png" alt="Fixed Data Input Image" /></a></p>
  <p><strong>###########  UPDATED TODAY Monday 3rd August 11.45 Uk time  #############</strong></p>
  <p>This is my workaround to overcome Problem 3 for phone numbers not pulling of correct.</p>
  <p>I have changed the Pattern part of the code, so now it pulls the REGXP pattern from the Sheet, <strong>Sheet1.Range D1</strong>. This way I can change the regxp pattern in the cell to pull off different phone number types.</p>
  <pre><code>''' ########## Phone Numbers Pattern ###########
          .Pattern = ThisWorkbook.Sheets(&quot;Sheet1&quot;).Range(&quot;D1&quot;)
          .Global = False
          .IgnoreCase = True
          Set phone_list = .Execute(html.body.innerHtml)
  </code></pre>
  <p>This is the Regxp pattern I am using for now, for uk. It is in placed in Sheet1 CELL D1</p>
  <pre><code>(?:\+1)?(?:\+[0-9])?\(?([0-9]{4})\)?[-. ]?([0-9]{4})[-. ]?([0-9]{3}?)
  </code></pre>
  <p>If anyone has a better pattern please post.</p>
  <p><strong>##########  Updated today Tuesday 5th August 2020 1:35 uk time  ##########</strong></p>
  <p>I have MSXML2.ServerXMLHTTP code which works much faster,  but misses a few emails and numbers. Where as the IE version I wrote and the code ANSWER written by SMTH pick up the extra emails and phone numbers. I changed the regxp patters in SMTH ANSWER to mine for better results.</p>
  <p>If anyone knows why then please advise, otherwise SMTH code is the answer as it does the same job as mine, but is written much better.</p>
  <pre><code>Private Sub CommandButton2_Click()
  '''######### NO IE THIS CODE IS FASTER ######
  Dim wb As Workbook
  Dim wsSheet As Worksheet, links As Variant, link As Variant
  Dim rw As Long
  Dim regxp As New RegExp, post As Object, phone_list As Object, email_list As Object
  Dim Html As New HTMLDocument
  
  ''''SHEET1 as sheet with URL
      Set wb = ThisWorkbook
      Set wsSheet = wb.Sheets(&quot;Sheet1&quot;)
     
      rw = wsSheet.Cells(wsSheet.Rows.Count, &quot;A&quot;).End(xlUp).Row
      links = wsSheet.Range(&quot;A2:A&quot; &amp; rw)
  
  For Each link In links
      'Set doc = NewHTMLDocument(CStr(link))
        Set Html = NewHTMLDocument(CStr(link))
  With regxp
  ''' ########## Phone Numbers Pattern ###########
          .Pattern = &quot;(?:\+1)?(?:\+[0-9])?\(?([0-9]{4})\)?[-. ]?([0-9]{4})[-. ]?([0-9]{3}?)&quot; '&quot;(?:\+1)?(?:\+[0-9])?\(?([0-9]{3})\)?[-. ]?([0-9]{3})[-. ]?([0-9]{3}?)&quot;
          .Global = False
          .IgnoreCase = True
          Set phone_list = .Execute(Html.body.innerHtml)
  ''' ########## Email Pattern ###########
          .Pattern = &quot;([a-zA-Z0-9_\-\.]+)@((\[[0-9]{1,3}\.[0-9]{1,3}\.[0-9]{1,3}\.)|(([a-zA-Z0-9\-]+\.)+))([a-zA-Z]{2,4}|[0-9]{1,3})(\]?)&quot;
          .Global = False
         .IgnoreCase = True
          Set email_list = .Execute(Html.body.innerHtml)
      
  
  '''########## PHONE LIST ############# ADD TO SHEET
  On Error Resume Next
      If phone_list(0) Is Nothing Then
          On Error Resume Next
              Sheet1.Cells(Sheet1.Cells(Sheet1.Rows.Count, &quot;B&quot;).End(xlUp).Row + 1, &quot;B&quot;).Value = &quot;-&quot;
      Else
          On Error Resume Next
              Sheet1.Cells(Sheet1.Cells(Sheet1.Rows.Count, &quot;B&quot;).End(xlUp).Row + 1, &quot;B&quot;).Value = phone_list(0)
      End If
  '''########## EMAIL LIST ############# ADD TO SHEET
  On Error Resume Next
        If email_list(0) Is Nothing Then
          On Error Resume Next
              Sheet1.Cells(Sheet1.Cells(Sheet1.Rows.Count, &quot;C&quot;).End(xlUp).Row + 1, &quot;C&quot;).Value = &quot;-&quot;
      Else
          On Error Resume Next
              Sheet1.Cells(Sheet1.Cells(Sheet1.Rows.Count, &quot;C&quot;).End(xlUp).Row + 1, &quot;C&quot;).Value = email_list(0)
      End If
  End With
  ''''navigate links
       Next link
  
  End Sub
  
  Public Function NewHTMLDocument(strURL As String) As Object
      Dim objHTTP As Object, objHTML As Object, strTemp As String
      Set objHTTP = CreateObject(&quot;MSXML2.ServerXMLHTTP&quot;)
      objHTTP.Open &quot;GET&quot;, strURL, False
      objHTTP.send
      If objHTTP.Status = 200 Then
          strTemp = objHTTP.responseText
      Set objHTML = CreateObject(&quot;htmlfile&quot;)
      objHTML.body.innerHtml = strTemp
      Set NewHTMLDocument = objHTML
  Else
     'There has been an error
  End If
  End Function
  </code></pre>