Macro for extracting email from multiple URLs

[riana]

Hi all,

I have a list of websites in Excel, in column A1:A1100. I would like a macro to find the email addresses on these websites, copy them, and paste them into B1:B1100. Is it possible?

Your help would be highly appreciated.

 

[mrshl9898]

I didn't see any in my search (all @'s were mailto), though I didn't look at all.

Sub getemailfromwebsite()
Dim ie As internetExplorer
Dim url As String
Dim x As Long
Dim html As htmldocument
Dim ElementCol As Object
Set html = CreateObject("htmlfile")
Application.ScreenUpdating = False
Set ie = CreateObject("internetexplorer.application")
ie.Visible = False
x = 2
Do While Sheet1.Cells(x, 1) <> ""
url = Sheet1.Cells(x, 1)
'url = "http://www.easyexcelanswers.com/"
ie.navigate url
Do While ie.readystate <> readystate_complete
Application.StatusBar = "loading website..."
DoEvents
Loop
Set html = ie.document
Set ElementCol = html.getElementsByTagName("a")


For Each link In ElementCol
    If InStr(link, "@") Then
        Cells(x, 2).Value = link
        'Cells(x, 2) = Right(link, Len(link) - InStr(link, ":"))
         Cells(x, 2).Columns.AutoFit
    End If
Next
x = x + 1


Loop
Set ie = Nothing
Application.StatusBar = ""
Application.ScreenUpdating = True
End Sub