如何根据字符串值过滤掉 URL 命中

Question

目前我已经使用下面的代码提取了 13,000 个 URL。然而，其中 3,000 人提出了来自 Facebook、Bloomberg 等网站的 URL。对于这些 URL，我一直在手动搜索名称，也许 20 个中有 1 个有宏错过的公司 URL。所以我的问题是：有没有一种方法可以编辑宏，以便如果 URL 页面包含字符串值（例如“facebook”或“wiki”），它将跳过该 URL 并继续搜索确实的 URL不包含字符串值？

我如何提取 URL 的代码：

Sub XMLHTTP()

    Dim url As String, lastRow As Long
    Dim XMLHTTP As Object, html As Object, objResultDiv As Object, objH3 As Object, link As Object
    Dim start_time As Date
    Dim end_time As Date

    lastRow = Range("A" & Rows.Count).End(xlUp).Row

    Dim cookie As String
    Dim result_cookie As String

    start_time = Time
    Debug.Print "start_time:" & start_time

    For i = 2 To lastRow

        url = "https://www.google.co.in/search?q=" & Cells(i, 1) & "&rnd=" & WorksheetFunction.RandBetween(1, 10000)

        Set XMLHTTP = CreateObject("MSXML2.serverXMLHTTP")
        XMLHTTP.Open "GET", url, False
        XMLHTTP.setRequestHeader "Content-Type", "text/xml"
        XMLHTTP.setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1; rv:25.0) Gecko/20100101 Firefox/25.0"
        XMLHTTP.send

            Set html = CreateObject("htmlfile")
        html.body.innerHTML = XMLHTTP.ResponseText
        Set objResultDiv = html.getelementbyid("rso")
        Set objH3 = objResultDiv.getelementsbytagname("H3")(0)
        Set link = objH3.getelementsbytagname("a")(0)


        str_text = Replace(link.innerHTML, "<EM>", "")
        str_text = Replace(str_text, "</EM>", "")

        Cells(i, 2) = str_text
        Cells(i, 3) = link.href
        DoEvents
    Next

    end_time = Time
    Debug.Print "end_time:" & end_time

    Debug.Print "done" & "Time taken : " & DateDiff("n", start_time, end_time)
    MsgBox "done" & "Time taken : " & DateDiff("n", start_time, end_time)
End Sub

这是我用来根据字符串值过滤掉 URL 的代码：

Sub badURLs()
    Dim lr As Long ' Declare the variable
    lr = Cells(Rows.Count, 3).End(xlUp).Row ' Set the variable
    ' lr now contains the last used row in column A

    Application.ScreenUpdating = False

    For a = lr To 1 Step -1
        If InStr(1, Cells(a, 3), "bloomberg", vbTextCompare) > 0 _
        Or InStr(1, Cells(a, 3), "manta", vbTextCompare) > 0 _
        Or InStr(1, Cells(a, 3), "yellowpages", vbTextCompare) > 0 _
        Or InStr(1, Cells(a, 3), "yelp", vbTextCompare) > 0 _
        Or InStr(1, Cells(a, 3), "snapshot", vbTextCompare) > 0 _
        Or InStr(1, Cells(a, 3), "facebook", vbTextCompare) > 0 _
        Or InStr(1, Cells(a, 3), "wiki", vbTextCompare) > 0 _
        Or InStr(1, Cells(a, 3), "linkedin", vbTextCompare) > 0 _
        Or InStr(1, Cells(a, 3), "hoovers", vbTextCompare) > 0 Then


        'Compares for bloomberg, wiki, or hoovers. Enters loop if value is greater than 0
            With Cells(a, 3)
                .NumberFormat = "General"
                .Value = "NA"
            End With
        End If
    Next a

    Application.ScreenUpdating = True
End Sub

重申一下：我想知道是否可以（以及如何）根据第二个宏中的字符串值过滤掉第一个宏中的 URL。我希望这将使我获得更准确的 URL 命中，并且我不必手动搜索 3000 个公司名称，希望只有少数公司有有用的 URL。

Answer 1

编辑以展示用法：

我将在下面完整复制您的XMLHTTP() 代码，然后在其下方添加用户定义的函数以演示您的模块的布局方式。我所做的更改实际上只影响如下：Cells(i, 3) = href。在这种情况下，如果href 在 URL 的坏列表中，则不会在 Cells(i, 3) 中放入任何内容。如果您需要更复杂的业务逻辑，请告诉我们，我们会尽力提供帮助。

Sub XMLHTTP()

    Dim url As String, lastRow As Long
    Dim XMLHTTP As Object, html As Object, objResultDiv As Object, objH3 As Object, link As Object
    Dim start_time As Date
    Dim end_time As Date

    lastRow = Range("A" & Rows.Count).End(xlUp).Row

    Dim cookie As String
    Dim result_cookie As String

    start_time = Time
    Debug.Print "start_time:" & start_time

    For i = 2 To lastRow

        url = "https://www.google.co.in/search?q=" & Cells(i, 1) & "&rnd=" & WorksheetFunction.RandBetween(1, 10000)

        Set XMLHTTP = CreateObject("MSXML2.serverXMLHTTP")
        XMLHTTP.Open "GET", url, False
        XMLHTTP.setRequestHeader "Content-Type", "text/xml"
        XMLHTTP.setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1; rv:25.0) Gecko/20100101 Firefox/25.0"
        XMLHTTP.send

            Set html = CreateObject("htmlfile")
        html.body.innerHTML = XMLHTTP.ResponseText
        Set objResultDiv = html.getelementbyid("rso")
        Set objH3 = objResultDiv.getelementsbytagname("H3")(0)
        Set link = objH3.getelementsbytagname("a")(0)


        str_text = Replace(link.innerHTML, "<EM>", "")
        str_text = Replace(str_text, "</EM>", "")

        Cells(i, 2) = str_text
        If funcBadUrls(Cells(i, 1)) then
            Cells(i, 3) = "" 
        Else    
            Cells(i, 3) = link.href
        End If
        DoEvents
    Next

    end_time = Time
    Debug.Print "end_time:" & end_time

    Debug.Print "done" & "Time taken : " & DateDiff("n", start_time, end_time)
    MsgBox "done" & "Time taken : " & DateDiff("n", start_time, end_time)
End Sub

Function funcBadURLs(sInput as String) as Boolean
    Dim bResult as Boolean
        If InStr(1, sInput, "bloomberg", vbTextCompare) > 0 _
        Or InStr(1, sInput, "manta", vbTextCompare) > 0 _
        Or InStr(1, sInput, "yellowpages", vbTextCompare) > 0 _
        Or InStr(1, sInput, "yelp", vbTextCompare) > 0 _
        Or InStr(1, sInput, "snapshot", vbTextCompare) > 0 _
        Or InStr(1, sInput, "facebook", vbTextCompare) > 0 _
        Or InStr(1, sInput, "wiki", vbTextCompare) > 0 _
        Or InStr(1, sInput, "linkedin", vbTextCompare) > 0 _
        Or InStr(1, sInput, "hoovers", vbTextCompare) > 0 Then
            bResult = True
        Else
            bResult = False
        End If
     funcBadUrls = bResult
End Sub

如果我理解正确，您想在第一个子例程中忽略BadUrls。如果是这样，请考虑基于第二个例程创建一个Function，如果错误则返回 true，否则返回 false。然后您可以根据需要构建逻辑。例如：

Function funcBadURLs(sInput as String) as Boolean
    Dim bResult as Boolean
        If InStr(1, sInput, "bloomberg", vbTextCompare) > 0 _
        Or InStr(1, sInput, "manta", vbTextCompare) > 0 _
        Or InStr(1, sInput, "yellowpages", vbTextCompare) > 0 _
        Or InStr(1, sInput, "yelp", vbTextCompare) > 0 _
        Or InStr(1, sInput, "snapshot", vbTextCompare) > 0 _
        Or InStr(1, sInput, "facebook", vbTextCompare) > 0 _
        Or InStr(1, sInput, "wiki", vbTextCompare) > 0 _
        Or InStr(1, sInput, "linkedin", vbTextCompare) > 0 _
        Or InStr(1, sInput, "hoovers", vbTextCompare) > 0 Then
            bResult = True
        Else
            bResult = False
        End If
     funcBadUrls = bResult
End Sub

使用它：

Sub Test()
    If funcBadUrls("www.bloomberg.com") then
        'Do whatever to skip
    Else
        MsgBox "Success"
    End If
End Sub

如果这有帮助，或者如果我误解了你的问题，请告诉我。