VBA批量获取NPI编号：表格数据处理、循环及弹窗点击问题

Great question! Let's tackle each of your issues one by one, starting with the blocking security popup, then implementing the row loop, and handling no-search-result scenarios. We'll also cover the recommended XHR approach to avoid IE-related headaches entirely.

1. Automatically Clicking the IE Security Popup #

Since you can't disable the IE security prompt via settings, we can use Windows API functions to detect the popup window and simulate a click on the "Yes" button. Add these declarations at the top of your VBA module (outside any subroutine):

Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As LongPtr, ByVal hWnd2 As LongPtr, ByVal lpsz1 As String, ByVal lpsz2 As String) As LongPtr
Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr

Const BM_CLICK = &HF5
Const WAIT_INTERVAL = 500 ' Wait 0.5 seconds between checks
Const MAX_WAIT = 10 ' Max 10 seconds to wait for popup

Then add this helper function to click the "Yes" button:

Sub ClickIEPopupYes()
    Dim popupHWND As LongPtr
    Dim buttonHWND As LongPtr
    Dim waitCounter As Integer
    
    waitCounter = 0
    Do
        ' Look for the IE security popup window (adjust title if yours differs)
        popupHWND = FindWindow(vbNullString, "Internet Explorer Security")
        If popupHWND <> 0 Then
            ' Find the "Yes" button (standard button class name)
            buttonHWND = FindWindowEx(popupHWND, 0, "Button", "Yes")
            If buttonHWND <> 0 Then
                SendMessage buttonHWND, BM_CLICK, 0, 0
                Exit Do
            End If
        End If
        waitCounter = waitCounter + 1
        Sleep WAIT_INTERVAL
    Loop Until waitCounter >= MAX_WAIT
End Sub

2. Loop Through Excel Rows & Fetch NPIs #

Modify your existing GetNpi subroutine to iterate over your spreadsheet rows, fill the search fields, and write results to adjacent cells. This example assumes:

• Last names in column A
• First names in column B
• State in column C
• NPIs written to column D
• Row 1 is a header row

Sub GetNpi()
    Dim ie As Object
    Dim ieDoc As Object
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    
    ' Set your target worksheet (update the sheet name)
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    
    ' Initialize IE
    Set ie = New InternetExplorer
    ie.Visible = True
    
    ' Navigate to the lookup site
    ie.navigate "npinumberlookup.org"
    Do While ie.readyState <> READYSTATE_COMPLETE Or ie.Busy
        DoEvents
    Loop
    
    ' Handle initial security popup
    ClickIEPopupYes()
    
    ' Loop through each data row
    For i = 2 To lastRow
        Set ieDoc = ie.document
        
        ' Fill search fields with spreadsheet data
        ieDoc.getElementById("last").Value = ws.Cells(i, "A").Value
        ieDoc.getElementById("first").Value = ws.Cells(i, "B").Value
        ieDoc.getElementById("pracstate").Value = ws.Cells(i, "C").Value
        
        ' Submit the search form
        ieDoc.getElementById("submit").Click
        
        ' Wait for results to load
        Do While ie.readyState <> READYSTATE_COMPLETE Or ie.Busy
            DoEvents
        Loop
        
        ' Extract and write NPI (adjust selector to match site's HTML)
        Dim npiElement As Object
        On Error Resume Next
        Set npiElement = ieDoc.querySelector(".npi-result .npi-value") ' Update this selector if needed
        On Error GoTo 0
        
        If Not npiElement Is Nothing Then
            ws.Cells(i, "D").Value = npiElement.innerText
        Else
            ' Handle no results case
            ws.Cells(i, "D").Value = "No NPI Found"
        End If
        
        ' Navigate back to search page for next iteration
        ie.navigate "npinumberlookup.org"
        Do While ie.readyState <> READYSTATE_COMPLETE Or ie.Busy
            DoEvents
        Loop
        ClickIEPopupYes() ' Rehandle popup if it reappears
    Next i
    
    ' Cleanup
    ie.Quit
    Set ie = Nothing
    MsgBox "NPI lookup completed!", vbInformation
End Sub

3. Recommended XHR Alternative (Faster & No IE Popups) #

As suggested, using XHR avoids IE entirely—no popups, faster execution, and more reliable for automation. Here's a complete XHR version:

Sub GetNpiWithXHR()
    Dim xhr As Object
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim postData As String
    Dim responseText As String
    Dim npiStart As Integer
    Dim npiEnd As Integer
    
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    
    Set xhr = CreateObject("MSXML2.XMLHTTP.6.0")
    
    For i = 2 To lastRow
        ' Construct POST data to match the site's form fields
        postData = "last=" & URLEncode(ws.Cells(i, "A").Value) & _
                   "&first=" & URLEncode(ws.Cells(i, "B").Value) & _
                   "&pracstate=" & URLEncode(ws.Cells(i, "C").Value) & _
                   "&submit=Search"
        
        ' Send POST request to the search endpoint
        xhr.Open "POST", "https://npinumberlookup.org/search", False
        xhr.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
        xhr.send postData
        
        responseText = xhr.responseText
        
        ' Extract NPI from the HTML response
        npiStart = InStr(responseText, "NPI Number:") + Len("NPI Number:")
        If npiStart > 0 Then
            npiEnd = InStr(npiStart, responseText, "<")
            ws.Cells(i, "D").Value = Trim(Mid(responseText, npiStart, npiEnd - npiStart))
        Else
            ws.Cells(i, "D").Value = "No NPI Found"
        End If
    Next i
    
    MsgBox "XHR-based NPI lookup completed!", vbInformation
End Sub

' Helper function to URL-encode form data
Function URLEncode(ByVal str As String) As String
    Dim bytes() As Byte
    Dim i As Integer
    bytes = StrConv(str, vbUnicode)
    For i = 0 To UBound(bytes) Step 2
        If bytes(i) >= 32 And bytes(i) <= 126 And bytes(i) <> 37 Then
            URLEncode = URLEncode & Chr(bytes(i))
        Else
            URLEncode = URLEncode & "%" & Hex(bytes(i)) & Hex(bytes(i + 1))
        End If
    Next i
End Function

Why XHR is Better: #

• No IE instance required, so no security popups or slow browser navigation.
• Faster execution since it skips rendering HTML.
• More stable for automated tasks.

内容的提问来源于stack exchange，提问作者josephkane