Updating a CODE

[Sharid]

Hi

Can some please help me update this code it was originally written by Rick Rothstein, the original post is HERE (but this post is messed up, the code is at the bottom of the thread.)
I am trying to get the code to work for multiple URL. The Urls List will be in Sheet1 Column A Starting from Row2 Down. I would like the results to go into Sheet1 column B next to the url. If nothing is found then either leave that cell blank or place a hyphen in it.

Sub GetEmail()
Dim IE As Object, WebText As String, Email As String
Const URL As String = "[URL]http://www.weissinc.com/contact[/URL]"
Set IE = CreateObject("InternetExplorer.Application")
IE.Navigate URL
While IE.ReadyState <> 4
DoEvents
Wend
WebText = IE.Document.body.innerhtml
IE.Quit
Set IE = Nothing
Email = GetEmailAddress(WebText)
'
' The Email variable contains the email address
' so do whatever you want with it here.
'
End Sub

Function GetEmailAddress(ByVal S As String) As String
Dim X As Long, AtSign As Long
Dim Locale As String, Domain As String
Locale = "[A-Za-z0-9.!#$%&'*/=?^_`{|}~+-]"
Domain = "[A-Za-z0-9._-]"
AtSign = InStr(S, "@")
If AtSign = 0 Then Exit Function
For X = AtSign To 1 Step -1
If Not Mid(" " & S, X, 1) Like Locale Then
S = Mid(S, X)
If Left(S, 1) = "." Then S = Mid(S, 2)
Exit For
End If
Next
AtSign = InStr(S, "@")
For X = AtSign + 1 To Len(S) + 1
If Not Mid(S & " ", X, 1) Like Domain Then
S = Left(S, X - 1)
If Right(S, 1) = "." Then S = Left(S, Len(S) - 1)
GetEmailAddress = S
Exit For
End If
Next
End Function

Thanks

 

[Sharid]

I was trying to create a new code, by trying to use above code with this one below. The code below works through a list of urls in Sheet1 column A. However I am struggling build a new code out of these two codes.

Private Sub CommandButton1_Click()
'''' Run main code Loop through URLS

Dim wb As Workbook
Dim X As Variant
Dim i, j, k, l As Integer
Dim r As Long, LR As Long
Dim wsSheet As Worksheet, links As Variant, IE As Object, link As Variant
Dim rw As Long

    i = 2
    k = 2
    l = 1
    '''SHEET1 as sheet with URL
    Set wb = ThisWorkbook
    Set wsSheet = wb.Sheets("Sheet1")
   
    '''Set IE = InternetExplorer
    Set IE = CreateObject("InternetExplorer.Application")
   
    rw = wsSheet.Cells(wsSheet.Rows.Count, "A").End(xlUp).Row
    links = wsSheet.Range("A2:A" & rw)
   
    '''IE Open Time per page 5sec and check links on Sheet2 Column A
    With IE
       .Visible = False
  
       For Each link In links
           .navigate (link)
           While .Busy Or .readyState <> 4: DoEvents: Wend

Dim doc As HTMLDocument
Set doc = IE.document
Dim dd As Variant
On Error Resume Next

               '''  If doc.getElementsByClassName("_64-f")(0) Is Nothing Then
                      '''  wsSheet.Cells(Sheet1.Cells(Sheet1.Rows.Count, "B").End(xlUp).Row + 1, "B").Value = "-"      
                ''' Else
                   ''' dd = doc.getElementsByClassName("_64-f")(0).innerText
                       ''' Sheet1.Cells(Sheet1.Cells(Sheet1.Rows.Count, "B").End(xlUp).Row + 1, "B").Value = dd
                       ''' Cells.WrapText = False
                ''' End If



On Error Resume Next
'''navigate links
      Next link
      
'Close IE Browser
    .Quit
    End With
    Set IE = Nothing

End Sub

 

[Sharid]

Just for info, I have also posted this on Stackoverflow Here

 

[Sharid]

Hi

I have managed to write the bulk of the code, but still stuck on a few issues. These are stated on the STACKOVER FLOW link which is Here. Please could someone help finish this off

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("Sheet1")

    'Set IE = InternetExplorer
    Set IE = CreateObject("InternetExplorer.Application")

    rw = wsSheet.Cells(wsSheet.Rows.Count, "A").End(xlUp).Row
    links = wsSheet.Range("A2:A" & rw)

    'IE Open Time per page 4sec and check links on Sheet2 Column A
    With IE
       .Visible = True
       Application.Wait (Now + TimeValue("00:00:04"))

       For Each link In links
           .navigate (link)
           While .Busy Or .readyState <> 4: DoEvents: Wend

Set html = .document

'PHONE NUMBER AND EMAIL SEARCH PATTERN
  With regxp
        .Pattern = "(?:\+1)?(?:\+[0-9])?\(?([0-9]{3})\)?[-. ]?([0-9]{3})[-. ]?([0-9]{4})"
        Set phone_list = .Execute(html.body.innerHTML)
        .Pattern = "[a-zA-Z0-9_.+-]+@[a-zA-Z0-9-]+\.[a-zA-Z0-9-.]+"
        Set email_list = .Execute(html.body.innerHTML)
    End With
   
'Put data into sheet1 columns B + C
    Sheet1.Cells(Sheet1.Cells(Sheet1.Rows.Count, "B").End(xlUp).Row + 1, "B").Value = phone_list(0)
    Sheet1.Cells(Sheet1.Cells(Sheet1.Rows.Count, "C").End(xlUp).Row + 1, "C").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, "B").End(xlUp).Row + 1, "B").Value = phone_list()
''''        Else
''''             wsSheet.Cells(Sheet1.Cells(Sheet1.Rows.Count, "B").End(xlUp).Row + 1, "B").Value = phone_list(0)
''''        End If
''''
''''        If regxp Is Nothing Then
''''            wsSheet.Cells(Sheet1.Cells(Sheet1.Rows.Count, "C").End(xlUp).Row + 1, "C").Value = email_list()
''''        Else
''''            wsSheet.Cells(Sheet1.Cells(Sheet1.Rows.Count, "C").End(xlUp).Row + 1, "C").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