VBA Code Scraper не размещает данные в правильных столбцах

Question

Код работает нормально, но мне нужно, чтобы он извлек ТОЛЬКО электронные письма и URL-адреса и поместил письмо в Sheet1 "Скребок" СЛЕДУЮЩЕЙ ЧЕРНОЙ СТРОКИ

Emails =  Column A
Urls =  Column B

В настоящее время он извлекает любой текст, электронные письма или URL и помещает их в column A или B.

Мне нужны только электронные письма или URL-адреса. Я застрял на этом некоторое время и не могу решить это

Также я не уверен, удаляет ли мой DELETE DUPLICATES дублирующиеся строки или дубликаты в столбце. Это ДОЛЖНЫ быть повторяющиеся строки.

Как работает код:

В Sheet2 «Список URL» У меня есть список URL, код проходит через это и помещает результаты в Sheet1 «Скребок». и удаляет любые дубликаты

Предполагается только очистить электронную почту и 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 свои ячейки в цикле.Я показываю метод, использующий вспомогательную функцию для определения lastRow в целевом листе и выписывания переменных для исправления столбцов за один раз.

Я могу помочь с реализацией интеграции цикла, если необходимо, но акцент здесь был сделан на объяснении того, чтоможет быть сделано для определения этих элементов, представляющих интерес, и как выписать в правильные столбцы.Tbh - дедупликация так легко выполняется в конце листа, но вы также можете использовать макро-рекордер, чтобы получить идеально функциональный код для этого единственного шага / использовать существующие ответы SO.

---

tl; dr;

Это было бы намного проще, если бы были разрешены псевдоклассы :contains / :has css.Вместо этого мой подход заключается в следующем:

1. email - найти атрибут href, значение которого начинается с mailto

веб-сайт - убедитесь, что на странице есть значок веб-сайта

Укажите родительский элемент для обоихзначок веб-сайта и адрес веб-сайта

Зацикливать все совпадения с этой родительской спецификацией, проверяя, содержит ли значок веб-сайта (именно в этом случае селекторы псевдо-классовупрощенные вещи).Если совпадение найдено, то у нас есть общий родитель и для иконки, и, надеюсь, адрес веб-сайта;используйте childOfSiblingCssSelector (в данном случае мы рассматриваем дочерний элемент следующего div) для выбора URL веб-сайта.

---

Примечания:

1. Все это поддерживается на достаточно высоком / общем уровне, так что вы можете настроить селекторы CSS так, чтобы они соответствовали различным сценариям.Следствие - может показаться немного многословным.
2. Предоставляются вспомогательные функции для обработки соответствия элементов.Назовите их так, чтобы они понимали, что они делают.Я думаю, что здесь есть место для улучшения.
3. Хотя технически второй помощник, GetText, может быть использован для извлечения адреса электронной почты (я бы, вероятно, добавил еще один аргумент в вызов функции, чтобы указать атрибут для извлечения) кака также адрес веб-сайта, в настоящее время кажется гораздо быстрее нацелиться на соответствующий href, как описано выше.
4. Я сохранил селекторы css как локальные переменные, близкие к их использованию;Вы могли бы иметь их как константы, ближе к верхней части модуля, где, возможно, проще получить доступ?Не знаете, как это происходит с течением времени / разные URL-адреса
5. Селекторы Css выбираются вместо .getElementsBy методов по двум причинам: 1) есть оптимизация браузера для селекторов css, поэтому, если правильно сформулировать, css будет быстрее 2Я хочу сохранить гибкость функций code / helper - у вас гораздо больше специфичности с помощью селекторов css с точки зрения того, какие шаблоны вы можете выразить.Я посчитал это важным, так как не знаю, какие будущие случаи вам могут понадобиться.
6. Я намеренно не использую имя класса и индекс, например, doc.getElementsByClassName("_50f4")(2).innerText, так как я не знаком с диапазоном возможных вариантов использования.;это кажется немного хрупким, поскольку зависит от последовательного упорядочения и нумерации элементов (по крайней мере, до этих индексов).

---

TODO:

1. Вместо того, чтобы каждый раз создавать новый HTMLDocument в GetText, более эффективно передавать другой аргумент HTMLDocument в сигнатуре функции, то есть из вызывающей процедуры.Рефакторинг может принять это во внимание.
2. Этот тип кодирования может пригодиться в будущем на основе классов.В частности, если необходимо добавить обработку ошибок и дополнительные функции.

---

VBA:

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. Библиотека объектов Microsoft 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

---

Редактировать:

Пример цикла - предполагается, что в столбце А между 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