Email Extracting

[Sharid]

My code extracts emails from a website, this bit is fine

It can also extract URLs from a site, the PROBLEM is that it extracts all LINKS and not just the domain name

Also I can only extract one or the other, either emails on their own or Links, when what I want is for it to be something like this, and each new record to go into the next Blank Row.

Emails	Urls
Jondoe@gmail.com	coolsite@mysite.com
janedoe@yahoo.com	supersite@mysite.com
	supersite@mysite.com
Dave@gmail.com	Coolsite@mysite.com
Joeblogs@hotmail.com	nicesite@mysite.com

<tbody>
</tbody>

Private Sub CommandButton1_Click()

Dim Collection As MSHTML.IHTMLElementCollection
Dim element As Object
Dim i As Integer

i = 1
[COLOR=#008000]'k = 2
[/COLOR]
'Currently it only extracts from 1 url but I can set it to extract from a list
URL = "https://www.dvscommercials.co.uk/"


Set XMLHTTP = CreateObject("MSXML2.XMLHTTP")
  XMLHTTP.Open "GET", URL, False
    XMLHTTP.setRequestHeader "Content-type", "text/xml"
      XMLHTTP.send

Set HTML = CreateObject("htmlfile")
  HTML.body.innerHTML = XMLHTTP.responseText
  Set Collection = HTML.getElementsByTagName("a")

For Each element In Collection
 On Error Resume Next

Email = element.href
 If InStr(Email, "@") Then
 [COLOR=#008000] 'If InStr(Email, "@") = 0 Then  [B]'For Extracting All URLs[/B][/COLOR]
  ThisWorkbook.Sheets(1).Cells(i, 1).Value = element.href
 [COLOR=#008000] 'ThisWorkbook.Sheets(1).Cells(k, 2).Value = element.href[/COLOR]
   Email = Replace(Email, "mailto:", "")
   ThisWorkbook.Sheets(1).Cells(i, 1).Value = Email

i = i + 1
End If

[COLOR=#008000]'End If[/COLOR]
Next element

End Sub

Thanks for having a look

 

[Sharid]

I am really stuck on this one, if anyone can help I would really appreciate it.

Also I have found that it has issues with URLS that are Http it seem to be fine with Https. If someone can just help with the first half that would be great.

Thanks