VBA Code Scraper不在右列中放置数据

Question

该代码可以正常工作，但是我只需要提取电子邮件和URL并将其放置在Sheet1“ Scraper”中即可。NEXT BLANK ROW

Emails =  Column A
Urls =  Column B

目前，它会提取任何文本，电子邮件或URL，并将它们放在column A或中B。

我只需要电子邮件或URL。我已经坚持了一段时间，似乎无法解决

另外，我不确定我的DELETE DUPLICATES是否要删除重复的行或列中的重复项。它应该是重复的行。

代码的工作方式：

在Sheet2“ URL列表”上，我有一个URL列表，代码将通过该列表运行并将结果放置到Sheet1“ Scraper”上。并删除所有重复项

它应该只是一个刮板电子邮件和URL，并将它们放入Column A，B下一步空白行。

我已尝试解决此问题，但超出了我的范围。

Private Sub fbStart_Click()
'Set sheet2 URL List and open Internet Explorer
    Dim lr          As Long
    Dim x           As Long
    Dim arr()       As Variant
    Dim wks         As Worksheet
    Dim ie          As Object
    Dim dd(1 To 2)  As String
    Dim Fr          As Long

    On Error Resume Next
    Application.ScreenUpdating = False

    Set wks = ThisWorkbook.Sheets("Url List")
    With wks
        Fr = .Cells(.Rows.Count, 6).End(xlUp).Offset(1).Row
        lr = .Cells(.Rows.Count, 1).End(xlUp).Row
        .Cells(1, 5).Value = lr
        arr = .Range(.Cells(Fr, 1), .Cells(lr, 1)).Value
    End With

    'Show Internet Explorer and add delay in seconds if needed
    Set ie = CreateObject("InternetExplorer.Application")
    With ie
        .Visible = True
        Application.Wait Now + TimeValue("0:00:0")

        For x = LBound(arr, 1) To UBound(arr, 1)
            .navigate arr(x, 1)
            wtime = Time
            Do While .Busy Or .readyState <> 4
                DoEvents

            'Skip pages with Captchas  + write the word Captcha in Sheet 2 Column C
                If Time > (wtime + TimeValue("00:00:10")) Then
                    Cells(x + 1, "C").Value = "Captcha"
                    Exit Do
                End If
            Loop

            On Error Resume Next
            'Variable for document or data which need to be extracted out of webpage, change innertext number if same class used
            Dim doc As HTMLDocument
            Set doc = ie.document
            dd(1) = doc.getElementsByClassName("_50f4")(2).innerText
            dd(2) = doc.getElementsByClassName("_50f4")(3).innerText


            'Paste the web data into Sheet1 "Scraper" in next BLANK ROW
            With Sheet1
                .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Resize(, 2).Value = dd
            End With

            ' Put A number 1 in Sheet2 "Url List"column B to notify this URL is done
            Sheets("Url List").Range("B" & Rows.Count).End(xlUp).Offset(1, 0).Value = 1

             'Deletes duplicates in column A Sheet1
            Columns(1).RemoveDuplicates Columns:=Array(1)
            Columns(2).RemoveDuplicates Columns:=Array(1)

             'Count No1 in sheet2 Column B
            With Worksheets("Url List")
                Lastrow = .Cells(.Rows.Count, "B").End(xlUp).Row
                Sheets("Url List").Range("B1").Value = Lastrow
            End With
            Call Autoclick_Click
        Next x
       .Quit
    End With

    'Hide FaceBook Scraper Form
    ScraperForm.Hide

End Sub

Answer 1

下面向您展示如何处理查找电子邮件和网站地址。您已经有了循环和重复数据删除功能。以下是提取所需信息的辅助方法。您可以简单地从变量分配email到website循环中的单元格。我展示了一种使用辅助函数来确定目标表中的最后一行并一次性写出变量以更正列的方法。

如果需要，我可以帮助实现循环集成，但这里的重点是解释可以做什么来识别这些感兴趣的元素以及如何写入正确的列。老实说 - 去重复很容易在最后的工作表中完成，但您也可以使用宏记录器来获取该单步的完美功能代码/使用现有的 SO 答案。

太长；博士；

如果允许:contains/ css 伪类，这会容易得多 。:has相反，我的方法如下：

1. email - 查找href其值开头的属性mailto

2. 网站- 检查页面上是否有网站图标

指定网站图标和网站地址的父级

循环所有匹配到该父规范的检查是否包含网站图标（这是伪类选择器可以简化事情的地方）。如果找到匹配，那么我们就有了图标和网站地址的共享父级；使用childOfSiblingCssSelector（在本例中我们正在查看以下 div 的子级）CSS 选择器来提取网站 url。

笔记：

1. 整个事情保持相当高的水平/通用，这样你就可以调整你的CSS选择器以适应不同的场景。结果 - 可能看起来有点冗长。
2. 提供辅助函数来处理元素匹配。以对他们所做的事情有意义的方式命名它们。我认为这里还有一些改进的空间。
3. 虽然从技术上讲，第二个帮助器GetText可用于提取电子邮件地址（我可能会向函数调用添加另一个参数以指定要提取的属性）以及网站地址，但目前，简单地定位适当的地址似乎要快得多href如上所述。
4. 我将 css 选择器保留为接近其用法的局部变量；您可以将它们作为常量，靠近模块顶部，也许更容易访问？如果没有看到随着时间的推移/不同的网址如何表现，不确定
5. 选择CSS选择器而不是.getElementsBy方法有两个原因：1）浏览器对CSS选择器进行了优化，因此，如果制定得当，CSS会更快2）我想保留代码/辅助函数的灵活性 - 您对CSS选择器有更多的特异性css 选择器根据您可以表达的模式而定。我认为这很重要，因为我不知道您将来可能需要处理哪些案件。
6. 我故意不使用类名和索引，例如doc.getElementsByClassName("_50f4")(2).innerText，因为我不熟悉潜在用例的范围；这感觉有点脆弱，因为依赖于元素的一致排序和编号（至少达到这些索引）。

去做：

1. 与HTMLDocument每次在 中实例化一个新的参数相比，在函数签名中GetText传递另一个参数（即从调用过程中）传递另一个参数会更有效 。HTMLDocument重构可以考虑到这一点。
2. 这种类型的编码将来可能适合基于类。特别是如果要添加错误处理和其他功能。

编程语言：

Option Explicit
'VBE > Tools > References > HTML Object Library
Public Sub test()
    Dim ie As Object, ws As Worksheet
    Set ie = CreateObject("InternetExplorer.Application")
    Set ws = ThisWorkbook.Worksheets("Scraper")

    With ie
        .Visible = True
        .Navigate2 "https://www.facebook.com/pg/SalemFordNH/about/?ref=page_internal%5Blink%5D"

        While .Busy Or .readyState < 4: DoEvents: Wend

        With .document

            Dim email As String, website As String, iconCssSelector As String
            'iconCssSelector for website icon in this instance
            iconCssSelector = "[src='https://static.xx.fbcdn.net/rsrc.php/v3/yV/r/EaDvTjOwxIV.png']"

            If ElementIsPresent(ie.document, "[href^=mailto]") Then
                email = ie.document.querySelector("[href^=mailto]").innerText
            Else
                email = "Not found"
            End If

            Dim parents As Object, sharedParentCssSelector As String, childOfSiblingCssSelector As String
            sharedParentCssSelector = "._5aj7" 'target parent of both icon and the website link
            childOfSiblingCssSelector = "._50f4" '< to target website address after finding right parent

            If ElementIsPresent(ie.document, iconCssSelector) _
                And ElementIsPresent(ie.document, sharedParentCssSelector) Then

                Set parents = ie.document.querySelectorAll(sharedParentCssSelector) 'css selector used to allow for greater flexibility in element matching
                website = GetText(ie.document, parents, iconCssSelector, childOfSiblingCssSelector)
            Else
                website = "Not found"
            End If
        End With
        'Assumes headers already present
        Dim nextRow As Long
        nextRow = GetLastRow(ws, 1) + 1
        ws.Cells(nextRow, 1).Resize(1, 2) = Array(email, website)
        .Quit
    End With
End Sub

Public Function ElementIsPresent(ByVal document As HTMLDocument, ByVal cssSelector As String) As Boolean
    ElementIsPresent = document.querySelectorAll(cssSelector).length > 0
End Function

Public Function GetText(ByVal document As HTMLDocument, ByVal parents As Object, ByVal iconCssSelector As String, ByVal childOfSiblingCssSelector As String) As String
    'in this instance and with microsoft IE DOM you cannot select for parent of an element with pseudo class _
    of :has(>child); nor use :contains... instead pass expected parent selector, that houses _
    both the icon element for website and the website address itself, and loop all matches checking for website icon _
    if found use childOfSiblingCssSelector to extract
    Dim i As Long, html As HTMLDocument
    Set html = New HTMLDocument

    For i = 0 To parents.length - 1
        html.body.innerHTML = parents.item(i).innerHTML
        If ElementIsPresent(html, iconCssSelector) Then
            GetText = html.querySelector(childOfSiblingCssSelector).innerText
            Exit Function
        End If
    Next
    GetText = "Not found"
End Function

Public Function GetLastRow(ByVal ws As Worksheet, Optional ByVal columnNumber As Long = 1) As Long
    With ws
        GetLastRow = .Cells(.rows.Count, columnNumber).End(xlUp).Row
    End With
End Function

项目参考（VBE > 工具 > 参考）：

1. 微软HTML对象库

补充阅读：

1. https://developer.mozilla.org/en-US/docs/Web/CSS/CSS_Selectors
2. https://developer.mozilla.org/en-US/docs/Web/API/Document/querySelectorAll
3. https://developer.mozilla.org/en-US/docs/Web/API/Document/querySelector

编辑：

循环示例 - 假设 A 列中 url 之间没有空行。

Option Explicit
'VBE > Tools > References > HTML Object Library
Public Sub test()
    Dim ie As Object, ws As Worksheet, wsUrls As Worksheet, urls()
    Set ie = CreateObject("InternetExplorer.Application")
    Set ws = ThisWorkbook.Worksheets("Scraper")
    Set wsUrls = ThisWorkbook.Worksheets("Url List")

    With wsUrls
        urls = Application.Transpose(.Range("A2:A" & .Cells(.rows.Count, "A").End(xlUp).Row).Value)
    End With
    Dim results(), r As Long
    ReDim results(1 To UBound(urls), 1 To 2)

    With ie
        .Visible = True

        For r = LBound(urls) To UBound(urls)
            .Navigate2 urls(r)

            While .Busy Or .readyState < 4: DoEvents: Wend

            With .document

                Dim email As String, website As String, iconCssSelector As String
                'iconCssSelector for website icon in this instance
                iconCssSelector = "[src='https://static.xx.fbcdn.net/rsrc.php/v3/yV/r/EaDvTjOwxIV.png']"

                If ElementIsPresent(ie.document, "[href^=mailto]") Then
                    email = ie.document.querySelector("[href^=mailto]").innerText
                Else
                    email = "Not found"
                End If

                Dim parents As Object, sharedParentCssSelector As String, childOfSiblingCssSelector As String
                sharedParentCssSelector = "._5aj7" 'target parent of both icon and the website link
                childOfSiblingCssSelector = "._50f4" '< to target website address after finding right parent

                If ElementIsPresent(ie.document, iconCssSelector) _
        And ElementIsPresent(ie.document, sharedParentCssSelector) Then

                    Set parents = ie.document.querySelectorAll(sharedParentCssSelector) 'css selector used to allow for greater flexibility in element matching
                    website = GetText(ie.document, parents, iconCssSelector, childOfSiblingCssSelector)
                Else
                    website = "Not found"
                End If
            End With
            'Assumes headers already present
            Dim nextRow As Long
            results(r, 1) = email
            results(r, 2) = website
        Next
        .Quit
    End With
    nextRow = GetLastRow(ws, 1) + 1
    ws.Cells(nextRow, 1).Resize(UBound(results, 1), UBound(results, 2)) = results
End Sub

Public Function ElementIsPresent(ByVal document As HTMLDocument, ByVal cssSelector As String) As Boolean
    ElementIsPresent = document.querySelectorAll(cssSelector).length > 0
End Function

Public Function GetText(ByVal document As HTMLDocument, ByVal parents As Object, ByVal iconCssSelector As String, ByVal childOfSiblingCssSelector As String) As String
    'in this instance and with microsoft IE DOM you cannot select for parent of an element with pseudo class _
    of :has(>child); nor use :contains... instead pass expected parent selector, that houses _
    both the icon element for website and the website address itself, and loop all matches checking for website icon _
    if found use childOfSiblingCssSelector to extract
    Dim i As Long, html As HTMLDocument
    Set html = New HTMLDocument

    For i = 0 To parents.length - 1
        html.body.innerHTML = parents.item(i).innerHTML
        If ElementIsPresent(html, iconCssSelector) Then
            GetText = html.querySelector(childOfSiblingCssSelector).innerText
            Exit Function
        End If
    Next
    GetText = "Not found"
End Function

Public Function GetLastRow(ByVal ws As Worksheet, Optional ByVal columnNumber As Long = 1) As Long
    With ws
        GetLastRow = .Cells(.rows.Count, columnNumber).End(xlUp).Row
    End With
End Function