编辑:更多信息 - 该程序的目标是从现有的名称列表中提取，搜索网站，并带回相应的 NPI 编号。感谢用户@omegastripes，我被建议将注意力转移到 XHR。
我的问题是关于如何使用提供者的名称填充搜索并循环，以便它将在剩余提供者的电子表格中的下一个单元格中返回 NPI。
相关，如果没有从搜索中填充，该怎么办
原帖:标题 - 你想继续吗？ Internet Explorer 弹出窗口 - VBA
Internet Security 弹出窗口阻止我的代码继续。通常我会禁用此请求，但由于使用工作计算机，我的计算机安全访问受到限制。
我的问题，有没有办法使用 VBA 在此弹出窗口上单击"is"？
到目前为止，这是我的代码。
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
最佳答案
更新
尝试使用以下代码从工作表中检索名称的 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)[^>]*>| |\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 对其进行解析的原因。关于正则表达式: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 协议(protocol)
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)[^>]*>| |\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
点击提交后，代码中的所有数据都可以通过浏览器开发者工具在网络选项卡上轻松获取，例如:
上面的代码为我返回输出如下:
关于vba - 从电子表格引用单元格并填充相应的单元格，我们在Stack Overflow上找到一个类似的问题： https://stackoverflow.com/questions/48237514/