求助：VBA实现VLOOKUP实时替换用户名，多工作表批量处理

一、实时替换（工作表Change事件） #

将以下代码放入需要监控的工作表代码模块中（若需批量生效，可改用工作簿级事件）：

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim monitorRange As Range
    Dim wsSource As Worksheet
    Dim cell As Range
    Dim lookupValue As String
    Dim result As Variant
    
    ' 指定数据源工作表
    Set wsSource = ThisWorkbook.Sheets("Sheet2")
    ' 定义用户作答的监控区域（CELL 0）
    Set monitorRange = Intersect(Me.Range("A:A,D:D,G:G,J:J,M:M,P:P,S:S"), Me.Range("16:30,42:56,68:82,95:109,122:135,147:161"))
    
    ' 判断变更单元格是否在监控范围内
    If Not Intersect(Target, monitorRange) Is Nothing Then
        For Each cell In Intersect(Target, monitorRange)
            ' 写入系统用户名和时间戳
            cell.Offset(0, 1).Value = Environ("Username")
            cell.Offset(0, 2).Value = Now
            
            ' 实时替换用户名为对应姓氏
            lookupValue = cell.Offset(0, 1).Value
            result = Application.VLookup(lookupValue, wsSource.Range("A5:B17"), 2, False)
            
            If Not IsError(result) Then
                cell.Offset(0, 1).Value = result
            Else
                cell.Offset(0, 1).Value = "未找到对应姓氏"
            End If
        Next cell
    End If
End Sub

二、批量处理所有工作表（一次性替换已有数据） #

执行以下宏可一次性完成26个工作表的用户名替换：

Sub BatchReplaceUsernames()
    Dim ws As Worksheet
    Dim wsSource As Worksheet
    Dim lookupRange As Range
    Dim cell As Range
    Dim lookupValue As String
    Dim result As Variant
    
    Set wsSource = ThisWorkbook.Sheets("Sheet2")
    
    ' 遍历所有目标工作表
    For Each ws In ThisWorkbook.Worksheets
        ' 跳过数据源工作表
        If ws.Name <> "Sheet2" Then
            ' 定义用户名所在的目标区域（CELL 1）
            Set lookupRange = Intersect(ws.Range("B:B,E:E,H:H,K:K,N:N,Q:Q,T:T"), ws.Range("16:30,42:56,68:82,95:109,122:135,147:161"))
            
            If Not lookupRange Is Nothing Then
                For Each cell In lookupRange
                    lookupValue = cell.Value
                    ' 跳过空单元格，避免无效查询
                    If lookupValue <> "" Then
                        result = Application.VLookup(lookupValue, wsSource.Range("A5:B17"), 2, False)
                        cell.Value = IIf(IsError(result), "未找到对应姓氏", result)
                    End If
                Next cell
            End If
        End If
    Next ws
    
    MsgBox "批量替换完成！"
End Sub

核心优化说明 #

• 精准区域锁定：用Intersect替代整列/整行范围，大幅减少无效遍历，提升运行效率。
• 逻辑整合：将写入用户名和替换姓氏的逻辑合并，实现作答后实时替换，无需二次操作。
• 批量适配：通过遍历工作表实现26个目标表的一次性处理，适配大规模数据场景。
• 错误处理：对未匹配的用户名设置自定义提示，避免单元格显示错误值。

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