Question

编辑：更多信息 - 此计划的目标是从现有名称列表中提取，搜索网站，并带回相应的NPI编号。感谢用户@omegastripes，我被建议将注意力转移到XHR上。我的问题是，如何使用提供者的名称填充搜索，并循环，以便它将在剩余提供者的电子表格中的下一个单元格中返回NPI。

相关，如果没有任何内容从搜索中填充

，该怎么办

原帖：标题 - 你想继续吗？ Internet Explorer弹出 - VBA

Internet Security弹出窗口阻止我的代码继续运行。通常我会禁用此请求，但由于使用了工作计算机，我的计算机安全访问受到限制。

我的问题是，有没有办法点击＆＃34;是＆＃34;在弹出这个使用VBA？

到目前为止，这是我的代码。

Sub GetNpi()

Dim ie As Object

'create a new instance of ie
Set ie = New InternetExplorer
ie.Visible = True

'goes to site
ie.navigate "npinumberlookup.org"
Do While ie.readyState <> READYSTATE_COMPLETE
     Loop

Set ieDoc = ie.document

'select search box last name and Fill in Search Box
ie.document.getElementById("last").Focus
ie.document.getElementById("last").Value = "testlastname"

'select search box first name and Fill in Search Box
ie.document.getElementById("first").Focus
ie.document.getElementById("first").Value = "testfirstname"

Do While ie.readyState <> READYSTATE_COMPLETE
     Loop

'select state drop down box enter TX
ie.document.getElementById("pracstate").Focus
ie.document.getElementById("pracstate").Value = "TX"

'click submit button
ie.document.getElementById("submit").Click

Answer 1

<强>更新

尝试以下代码从工作表中检索名称的NPI（指定姓氏，名字和州）：

Option Explicit

Sub TestListNPI()

    ' Prefix type + func
    ' Type: s - string, l - long, a - array
    ' Func: q - query, r - result
    Dim i As Long
    Dim j As Long
    Dim k As Long
    Dim sqLN As String
    Dim sqFN As String
    Dim aqFN
    Dim sqSt As String
    Dim arHdr
    Dim arRows
    Dim srMsg As String
    Dim srLN  As String
    Dim srFN As String
    Dim arFN
    Dim lrMNQty As Long
    Dim sOutput As String

    i = 2
    With Sheets(1)
        Do
            sqLN = .Cells(i, 1)
            If sqLN = "" Then Exit Do
            .Cells(i, 4) = "..."
            sqFN = .Cells(i, 2).Value
            aqFN = Split(sqFN)
            sqSt = "" & .Cells(i, 3)
            GetNPIData sqLN, aqFN(0), sqSt, arHdr, arRows, srMsg
            If srMsg = "OK" Then
                With CreateObject("Scripting.Dictionary")
                    For j = 0 To UBound(arRows, 1)
                        Do
                            srLN = arRows(j, 1)
                            If LCase(srLN) <> LCase(sqLN) Then Exit Do ' Last names should match
                            srFN = arRows(j, 3)
                            arFN = Split(srFN)
                            If LCase(arFN(0)) <> LCase(aqFN(0)) Then Exit Do ' First names should match
                            lrMNQty = UBound(arFN)
                            If UBound(aqFN) < lrMNQty Then lrMNQty = UBound(aqFN)
                            For k = 1 To lrMNQty
                                Select Case True
                                    Case LCase(arFN(k)) = LCase(aqFN(k)) ' Full match
                                    Case Len(arFN(k)) = 1 And LCase(arFN(k)) = LCase(Left(aqFN(k), 1)) ' First letter match
                                    Case Len(arFN(k)) = 2 And Right(arFN(k), 1) = "." And LCase(Left(arFN(k), 1)) = LCase(Left(aqFN(k), 1)) ' First letter with dot match
                                    Case Else ' No matches
                                        Exit Do
                                End Select
                            Next
                            .Add arRows(j, 0), arRows(j, 1) & " " & arRows(j, 3)
                        Loop Until True
                    Next
                    Select Case .Count
                        Case 0
                            sOutput = "No matches"
                        Case 1
                            sOutput = .Keys()(0)
                        Case Else
                            sOutput = Join(.Items(), vbCrLf)
                    End Select
                End With
            Else
                sOutput = srMsg
            End If
            .Cells(i, 4) = sOutput
            DoEvents
            i = i + 1
        Loop
    End With
    MsgBox "Completed"

End Sub

Sub GetNPIData(sLastName, sFirstName, sState, aResultHeader, aResultRows, sStatus)

    Dim sContent As String
    Dim i As Long
    Dim j As Long
    Dim aHeader() As String
    Dim aRows() As String

    ' Retrieve HTML content via XHR
    With CreateObject("MSXML2.XMLHTTP")
        .Open "POST", "http://npinumberlookup.org/getResults.php", False
        .SetRequestHeader "content-type", "application/x-www-form-urlencoded"
        .Send _
            "last=" & EncodeUriComponent(sLastName) & _
            "&first=" & EncodeUriComponent(sFirstName) & _
            "&pracstate=" & EncodeUriComponent(sState) & _
            "&npi=" & _
            "&submit=Search" ' Setup request parameters
        sContent = .ResponseText
    End With
    ' Parse with RegEx
    Do ' For break
        With CreateObject("VBScript.RegExp")
            .Global = True
            .MultiLine = True
            .IgnoreCase = True
            ' Minor HTML simplification
            .Pattern = "<(?!/td|/tr|/th|td|tr|th|a href)[^>]*>|&nbsp;|\r|\n|\t"
            sContent = .Replace(sContent, "")
            .Pattern = "<a [^>]*href=""([^""]*)"".*?</td>"
            sContent = .Replace(sContent, "$1</td>")
            .Pattern = "<(\w+)\b[^>]+>"
            sContent = .Replace(sContent, "<$1>")
           ' Extract header
            .Pattern = "<tr>((?:<th>.*?</th>)+)</tr>"
            With .Execute(sContent)
                If .Count <> 1 Then
                    sStatus = "No header"
                    Exit Do
                End If
            End With
            .Pattern = "<th>(.*?)</th>"
            With .Execute(sContent)
                ReDim aHeader(0, 0 To .Count - 1)
                For i = 0 To .Count - 1
                    aHeader(0, i) = .Item(i).SubMatches(0)
                Next
            End With
            aResultHeader = aHeader
           ' Extract data
            .Pattern = "<tr>((?:<td>.*?</td>)+)</tr>"
            With .Execute(sContent)
                If .Count = 0 Then
                    sStatus = "No rows"
                    Exit Do
                End If
                ReDim aRows(0 To .Count - 1, 0)
                For i = 0 To .Count - 1
                    aRows(i, 0) = .Item(i).SubMatches(0)
                Next
            End With
            .Pattern = "<td>(.*?)</td>"
            For i = 0 To UBound(aRows, 1)
                With .Execute(aRows(i, 0))
                    For j = 0 To .Count - 1
                        If UBound(aRows, 2) < j Then ReDim Preserve aRows(UBound(aRows, 1), j)
                        aRows(i, j) = Trim(.Item(j).SubMatches(0))
                    Next
                End With
            Next
            aResultRows = aRows
        End With
        sStatus = "OK"
    Loop Until True

End Sub

Function EncodeUriComponent(sText)
    Static oHtmlfile As Object
    If oHtmlfile Is Nothing Then
        Set oHtmlfile = CreateObject("htmlfile")
        oHtmlfile.parentWindow.execScript "function encode(s) {return encodeURIComponent(s)}", "jscript"
    End If
    EncodeUriComponent = oHtmlfile.parentWindow.encode(sText)
End Function

我的输出如下：

对于乘法输入，所有名称都输出在最后一列而不是NPI。

代码的一些解释。一般来说，RegEx不建议用于HTML解析，因此there is disclaimer。在这种情况下处理的数据非常简单，这就是使用RegEx解析的原因。关于RegEx：introduction（特别是syntax），introduction JS，VB flavor。简化使HTML代码在某种程度上适合于解析。图案：

<(?!/td|/tr|/th|td|tr|th|a href)[^>]*>| |\r|\n|\t用于删除空格，所有标记用于表格标记和链接，替换为""。
<a [^>]*href="([^"]*)".*?</td>通过替换为$1</td>来保留链接地址。
<(\w+)\b[^>]+>通过替换为<$1>来删除所有不必要的标记属性。
<tr>((?:<th>.*?</th>)+)</tr>匹配每个表标题行。
<th>(.*?)</th>匹配每个标题单元格。
<tr>((?:<td>.*?</td>)+)</tr>匹配每个表格数据行。
<td>(.*?)</td>匹配每个数据单元格。

了解如何在replacemnets的每一步中更改HTML内容。

初步回答

避免弹出而不是打扰它。

确保使用安全HTTP协议https://npinumberlookup.org。

你甚至可能根本不使用IE进行网页编写，XHR是更好的选择，因为它更加可靠和快速，但它需要一些知识和经验。这是一个简单的例子：

Option Explicit

Sub Test()

    Dim sContent As String
    Dim i As Long
    Dim j As Long
    Dim aHeader() As String
    Dim aRows() As String

    ' Retrieve HTML content via XHR
    With CreateObject("MSXML2.XMLHTTP")
        .Open "POST", "http://npinumberlookup.org/getResults.php", False
        .SetRequestHeader "content-type", "application/x-www-form-urlencoded"
        .Send _
            "last=smith" & _
            "&first=michael" & _
            "&pracstate=NC" & _
            "&npi=" & _
            "&submit=Search" ' Setup request parameters
        sContent = .ResponseText
    End With
    ' Parse with RegEx
    Do ' For break
        With CreateObject("VBScript.RegExp")
            .Global = True
            .MultiLine = True
            .IgnoreCase = True
            ' Minor HTML simplification
            .Pattern = "<(?!/td|/tr|/th|td|tr|th|a href)[^>]*>|&nbsp;|\r|\n|\t"
            sContent = .Replace(sContent, "")
            .Pattern = "<a [^>]*href=""([^""]*)"".*?</td>"
            sContent = .Replace(sContent, "$1</td>")
            .Pattern = "<(\w+)\b[^>]+>"
            sContent = .Replace(sContent, "<$1>")
           ' Extract header
            .Pattern = "<tr>((?:<th>.*?</th>)+)</tr>"
            With .Execute(sContent)
                If .Count <> 1 Then
                    MsgBox "No header found"
                    Exit Do
                End If
            End With
            .Pattern = "<th>(.*?)</th>"
            With .Execute(sContent)
                ReDim aHeader(0, 0 To .Count - 1)
                For i = 0 To .Count - 1
                    aHeader(0, i) = .Item(i).SubMatches(0)
                Next
            End With
           ' Extract data
            .Pattern = "<tr>((?:<td>.*?</td>)+)</tr>"
            With .Execute(sContent)
                If .Count = 0 Then
                    MsgBox "No rows found"
                    Exit Do
                End If
                ReDim aRows(0 To .Count - 1, 0)
                For i = 0 To .Count - 1
                    aRows(i, 0) = .Item(i).SubMatches(0)
                Next
            End With
            .Pattern = "<td>(.*?)</td>"
            For i = 0 To UBound(aRows, 1)
                With .Execute(aRows(i, 0))
                    For j = 0 To .Count - 1
                        If UBound(aRows, 2) < j Then ReDim Preserve aRows(UBound(aRows, 1), j)
                        aRows(i, j) = .Item(j).SubMatches(0)
                    Next
                End With
            Next
        End With
    Loop Until True
    ' Output
    With ThisWorkbook.Sheets(1)
        .Cells.Delete
         Output2DArray .Cells(1, 1), aHeader
         Output2DArray .Cells(2, 1), aRows
         .Columns.AutoFit
    End With
    MsgBox "Completed"

End Sub

Sub Output2DArray(oDstRng As Range, aCells As Variant)

    With oDstRng
        .Parent.Select
        With .Resize( _
                UBound(aCells, 1) - LBound(aCells, 1) + 1, _
                UBound(aCells, 2) - LBound(aCells, 2) + 1)
            .NumberFormat = "@"
            .Value = aCells
        End With
    End With

End Sub

单击提交后，可以从网络选项卡上的浏览器开发人员工具轻松获取代码中的所有数据，例如：

上面的代码为我返回输出如下：

从电子表格引用单元格并填充相应的单元格

1 个答案: