修改Lookup UserInfo()宏实现多结果批量填充至工作表

以下是满足需求的修改后宏代码，会将匹配到的编号、对应姓名批量写入工作表，并统计出现次数；无匹配时弹出明确错误提示：

Sub LookupUserInfo()
    Dim userPrompt As String
    Dim searchRange As Range
    Dim firstFoundCell As Range
    Dim currentFoundCell As Range
    Dim outputSheet As Worksheet
    Dim outputRow As Long
    Dim matchCount As Long
    
    ' 设置输出结果的工作表（可根据实际修改表名）
    Set outputSheet = ThisWorkbook.Sheets("Results")
    
    ' 1. 提示用户输入编号
    userPrompt = InputBox("Enter the ID to look up:")
    
    ' 若用户取消输入则退出
    If userPrompt = "" Then Exit Sub
    
    ' 2. 设置搜索范围（数据库所在的Data表C列）
    Set searchRange = Sheets("Data").Columns("C")
    
    ' 3. 统计编号出现次数
    matchCount = WorksheetFunction.CountIf(searchRange, userPrompt)
    
    ' 4. 检查是否存在匹配结果
    If matchCount = 0 Then
        MsgBox "Error: The entered ID does not exist in the database.", vbExclamation
        Exit Sub
    End If
    
    ' 5. 找到第一个匹配单元格
    Set firstFoundCell = searchRange.Find(What:=userPrompt, LookIn:=xlValues, LookAt:=xlWhole)
    Set currentFoundCell = firstFoundCell
    
    ' 6. 准备输出区域（从第2行开始，假设第1行是表头）
    outputRow = 2
    ' 清空之前的结果（可根据需求删除此行保留历史数据）
    outputSheet.Range("A2:B" & outputSheet.Cells(outputSheet.Rows.Count, "A").End(xlUp).Row).ClearContents
    
    ' 7. 遍历所有匹配项并写入工作表
    Do
        ' 写入编号到A列，姓名到B列
        outputSheet.Cells(outputRow, "A").Value = userPrompt
        outputSheet.Cells(outputRow, "B").Value = currentFoundCell.Offset(0, 1).Value
        outputRow = outputRow + 1
        
        ' 查找下一个匹配项
        Set currentFoundCell = searchRange.FindNext(currentFoundCell)
        
        ' 循环终止条件：回到第一个匹配单元格
    Loop While Not currentFoundCell Is Nothing And currentFoundCell.Address <> firstFoundCell.Address
    
    ' 8. 在工作表中写入出现次数（示例放在C1单元格，可修改位置）
    outputSheet.Cells(1, "C").Value = "Total Occurrences: " & matchCount
    MsgBox "Lookup completed. " & matchCount & " records found and written to Results sheet.", vbInformation
End Sub

关键改动说明 #

• 统计匹配次数：用WorksheetFunction.CountIf直接获取编号在目标列的总出现次数，效率优于循环计数
• 遍历所有匹配结果：通过FindNext方法循环查找所有匹配项，解决原代码仅返回首个结果的问题
• 结果写入工作表：指定独立的输出工作表存储结果，逐行写入编号和对应姓名，同时支持清空旧结果避免混淆
• 明确错误提示：当无匹配时弹出带感叹号的错误框，清晰告知用户编号不存在
• 操作反馈：完成后弹出提示框告知记录数量，同时在工作表表头位置显示总出现次数

注意事项 #

• 确保工作簿中存在名为Results的工作表，或修改代码中Set outputSheet = ThisWorkbook.Sheets("Results")的表名
• 假设数据库中编号在Data表的C列，姓名在相邻的D列（对应Offset(0,1)），若姓名位置不同，修改Offset参数即可
• 若需要保留历史查询结果，删除outputSheet.Range("A2:B"...).ClearContents这行代码即可

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