来自 url 列表的电子邮件抓取工具答案

【问题标题】：Email scraper from a list of urls来自 url 列表的电子邮件抓取工具
【发布时间】：2020-11-07 09:37:54
【问题描述】：

我正在尝试构建的内容

在 Sheet1 列 A row2 下到 x 行，将有一个网站 URL 列表。我需要代码来浏览网址并找到电话号码和电子邮件，并将它们放在网址旁边的 B + C 列中，如果没有找到，请在单元格中放置一个连字符。

我几乎已经完成了这项工作。代码循环遍历 Sheet1 A 列中的 URL 列表，并提取电话号码和电子邮件，将它们放入 B 和 C 列。我编写的当前代码只有 3 个问题，这些问题如下所述问题 3 可能很简单修复。

新代码

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

'Application.Wait (Now + TimeValue("00:00:04"))
  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
   
    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

问题 1

如果没有要提取的项目，则代码不会转到下一个 url，出于某种原因，它只会停留在该页面上，或者我收到一条错误消息。例如网站有电话号码但没有电子邮件页面将不会导航到下一个网址。 我尝试使用 IF 语句 解决此问题，但无法正常工作。。 应该做什么如果没有可提取的内容，请转到 A 列中的下一个网址

问题 2

如果网站的安全证书无效或 url 为 DEAD，则代码不会导航到下一个 url，它会等待用户输入。如果我单击“否”表示我不想导航到该站点，则代码会崩溃。 如果证书无效或 url 为 DEAD，那么它应该移动到下一个 url，所以如果网站在 X 时间内没有加载，则移动到下一个 url。 不确定这是否也可以使用对于问题1

我想我需要这样的东西，但无法用我的代码Mr Excel

问题 3

这可能只是一个 excel 列格式问题，除非我在代码中弄错了电话号码表达式。如您所见，电话号码显示不正确。我不确定 excel 是否清除了“0”，这就是数字错误或电话号码表达错误的原因。

感谢您查看这三个问题中的任何一个，请有人帮助我。提前致谢。

2020 年 7 月 24 日英国时间 12:56 更新

我添加了一个更好的 Regxp 来查找电话号码，自从发布问题 3 以来，它已经改进了一点 .Pattern = "(?:\+1)?(?:\+[0-9])?\(?([0-9]{3})\)?[-. ]?([0-9]{3})[-. ]?([0-9]{4})" 但是它仍然剪切了一些数字，见下图，绿色的数字在找到的位置和最后一个数字不见了

也张贴在Excel先生Mr Excel。

####### 添加于今天英国时间 2020 年 7 月 30 日星期四下午 4:00 ########

我正在尝试使用 If 语句，因此如果没有找到任何内容，请添加连字符，见下文

If email_list Is Nothing Then
'On Error Resume Next
wsSheet.Cells(Sheet1.Cells(Sheet1.Rows.Count, "c").End(xlUp).Row + 1, "c").Value = "-"
Else
On Error Resume Next
wsSheet.Cells(Sheet1.Cells(Sheet1.Rows.Count, "c").End(xlUp).Row + 1, "c").Value = email_list(0)
End If
End With

但是我无法让它工作，On Error Resume Next 允许我移动到下一个 url 并摆脱第一条错误消息。

电子邮件现在就这样发送了，我已经对它们进行了颜色编码以便于查看。正如您从颜色中看到的那样，它们不 在正确的网址旁边，这就是为什么我试图在单元格中放置一个连字符，至少那个单元格将是填充日期将进入下一个空白单元格，从而使所有内容保持一致。

############## 更新于今天英国时间 2020 年 7 月 31 日星期五下午 1 点 26 分

我已经通过使用 IF 语句代码解决了数据 NOT 进入正确位置的问题。所以现在问题 1 和 2 似乎很好。只剩下问题 3，我认为这将是一个简单的修复 LOL。

问题是这样的

If regxp Is Nothing Then

应该是的

If Phone_List (0) Is Nothing Then

和

If Email_List (0) Is Nothing Then

########### 更新于今天英国时间 8 月 3 日星期一 11:45 #############

这是我克服电话号码不正确的问题 3 的解决方法。

我已经更改了代码的模式部分，所以现在它从工作表中提取 REGXP 模式，Sheet1.Range D1。这样我就可以更改单元格中的 regxp 模式以提取不同的电话号码类型。

''' ########## Phone Numbers Pattern ###########
        .Pattern = ThisWorkbook.Sheets("Sheet1").Range("D1")
        .Global = False
        .IgnoreCase = True
        Set phone_list = .Execute(html.body.innerHtml)

这是我现在使用的 Regxp 模式，适用于英国。它位于 Sheet1 CELL D1 中

(?:\+1)?(?:\+[0-9])?\(?([0-9]{4})\)?[-. ]?([0-9]{4})[-. ]?([0-9]{3}?)

如果有人有更好的模式，请发布。

########## 更新于今天英国时间 2020 年 8 月 5 日星期二 1:35 ##########

我有 MSXML2.ServerXMLHTTP 代码，它运行得更快，但遗漏了一些电子邮件和号码。在我编写的 IE 版本和 SMTH 编写的代码 ANSWER 中提取了额外的电子邮件和电话号码。我将 SMTH ANSWER 中的 regxp 模式更改为我的模式以获得更好的结果。

如果有人知道原因，请告知，否则 SMTH 代码就是答案，因为它与我的工作相同，但写得更好。

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("Sheet1")
   
    rw = wsSheet.Cells(wsSheet.Rows.Count, "A").End(xlUp).Row
    links = wsSheet.Range("A2:A" & rw)

For Each link In links
    'Set doc = NewHTMLDocument(CStr(link))
      Set Html = NewHTMLDocument(CStr(link))
With regxp
''' ########## Phone Numbers Pattern ###########
        .Pattern = "(?:\+1)?(?:\+[0-9])?\(?([0-9]{4})\)?[-. ]?([0-9]{4})[-. ]?([0-9]{3}?)" '"(?:\+1)?(?:\+[0-9])?\(?([0-9]{3})\)?[-. ]?([0-9]{3})[-. ]?([0-9]{3}?)"
        .Global = False
        .IgnoreCase = True
        Set phone_list = .Execute(Html.body.innerHtml)
''' ########## Email Pattern ###########
        .Pattern = "([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})(\]?)"
        .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, "B").End(xlUp).Row + 1, "B").Value = "-"
    Else
        On Error Resume Next
            Sheet1.Cells(Sheet1.Cells(Sheet1.Rows.Count, "B").End(xlUp).Row + 1, "B").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, "C").End(xlUp).Row + 1, "C").Value = "-"
    Else
        On Error Resume Next
            Sheet1.Cells(Sheet1.Cells(Sheet1.Rows.Count, "C").End(xlUp).Row + 1, "C").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("MSXML2.ServerXMLHTTP")
    objHTTP.Open "GET", strURL, False
    objHTTP.send
    If objHTTP.Status = 200 Then
        strTemp = objHTTP.responseText
    Set objHTML = CreateObject("htmlfile")
    objHTML.body.innerHtml = strTemp
    Set NewHTMLDocument = objHTML
Else
   'There has been an error
End If
End Function

【问题讨论】：

我已经为电话号码添加了一个更好的 regxp 模式，这已经做出了一些改进.Pattern = "(?:\+1)?(?:\+[0-9])?\(?([0-9]{3})\)?[-. ]?([0-9]{3})[-. ]?([0-9]{4})" 但是一些数字在开头或结尾被剪掉了，数字丢失了请参阅新图片
我可以用 On error resume next 解决问题 2 但是我无法解决问题 1 和问题 2，因为问题 2 中的一些数字被剪掉，如 2020 年 7 月 24 日所示图片帖子。我无法解决问题 1
你能分享几个网址，包括没有任何结果的网址吗？你为什么不选择 xhr 而不是 IE？
对于抓取，我建议使用 R 或 Python。
SIM 请查看附件中的下载文件 url，我附上了我在 link 上测试的工作簿。我正在使用 IE，因为这就是我所知道的。我在 VBA 和一般编程方面非常有限。我知道一些 VBA，所以其他语言如 R 或 Python 是我们现在的问题，因为我需要学习它们。

标签： excel vba web-scraping screen-scraping

【解决方案1】：

这是您可以使用宏循环遍历所有预定义链接以收集电子邮件和电话号码的方法。要弄清楚你的模式是否能找到任何东西，你想使用.Count 属性，如下所示。您可以随时替换我在下面使用的模式，因为它们与您的主要问题无关。

Sub GetEmailAndPhone()
    Dim IE As Object: Set IE = CreateObject("InternetExplorer.Application")
    Dim Rxp As Object: Set Rxp = CreateObject("VBScript.RegExp")
    Dim emailMatch As Object, phoneMatch  As Object, S$, cel As Range
    Dim Html As HTMLDocument

    For Each cel In Sheets("Sheet1").Range("A2:A" & Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row)
        With IE
            .Visible = False
            .navigate cel
            While .Busy Or .readyState <> 4: DoEvents: Wend
            Set Html = .document
        End With
        
        With Rxp
            .Pattern = "[a-zA-Z0-9_.+-]+@[a-zA-Z0-9-]+\.[a-zA-Z0-9-.]+"
            Set emailMatch = .Execute(Html.body.innerHTML)
            .Pattern = "(?:\+1)?(?:\+[0-9])?\(?([0-9]{3})\)?[-. ]?([0-9]{3})[-. ]?([0-9]{4})"
            Set phoneMatch = .Execute(Html.body.innerHTML)
        End With
        
        If emailMatch.Count >= 1 Then
            cel(1, 2) = emailMatch(0)
        Else:
            cel(1, 2) = "Not Found"
        End If
        
        If phoneMatch.Count >= 1 Then
            cel(1, 3) = phoneMatch(0)
        Else:
            cel(1, 3) = "Not Found"
        End If
    Next cel
End Sub

【讨论】：

我今天写了一个更新，请你看看并建议。否则我会用你的代码作为答案
您无法仅使用 xhr 获得类似的结果，因为您列表中的大多数站点都包含动态生成的内容，这些内容超出了 xmlhttp 请求的范围。谢谢。