Updating a CODE

Sharid

Well-known Member
Joined
Apr 22, 2007
Messages
865
Office Version
  1. 2016
Platform
  1. Windows
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.

VBA Code:
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
 

Some videos you may like

Excel Facts

Format cells as time
Select range and press Ctrl+Shift+2 to format cells as time. (Shift 2 is the @ sign).

Sharid

Well-known Member
Joined
Apr 22, 2007
Messages
865
Office Version
  1. 2016
Platform
  1. Windows
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.

VBA Code:
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

Well-known Member
Joined
Apr 22, 2007
Messages
865
Office Version
  1. 2016
Platform
  1. Windows
Just for info, I have also posted this on Stackoverflow Here
 

Sharid

Well-known Member
Joined
Apr 22, 2007
Messages
865
Office Version
  1. 2016
Platform
  1. Windows
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

VBA 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("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
 

Watch MrExcel Video

Forum statistics

Threads
1,114,493
Messages
5,548,370
Members
410,828
Latest member
A9Bosv3
Top