VBA问题：按用户测试脚本生成工作表时仅复制单条脚本

问题分析 #

现有代码的核心问题：

• rngUser仅初始化一次，且错误使用End(xlToLeft)（用户的脚本编号在用户名右侧，应使用xlToRight），导致所有用户都匹配第一行用户的脚本编号，范围完全错误
• 未复制Scripts表的表头到新工作表，用户工作表缺少字段标识
• 脚本范围rngScript初始化在循环外，若Scripts表后续新增行，会导致范围不完整

修正后的VBA代码 #

Sub CreateUserTestSheets()
    Dim wsScripts As Worksheet, wsUsers As Worksheet
    Dim lastUserRow As Long, lastScriptRow As Long, lastScriptCol As Long
    Dim userRow As Long, copyToRow As Long
    Dim userScriptsRng As Range
    Dim scriptCell As Range
    Dim wsUser As Worksheet
    
    ' 绑定固定工作表对象，避免ActiveSheet切换导致的错误
    Set wsScripts = ThisWorkbook.Sheets("Scripts")
    Set wsUsers = ThisWorkbook.Sheets("Users")
    
    ' 获取各表的边界行/列
    lastUserRow = wsUsers.Range("A" & wsUsers.Rows.Count).End(xlUp).Row
    lastScriptRow = wsScripts.Range("A" & wsScripts.Rows.Count).End(xlUp).Row
    lastScriptCol = wsScripts.Cells(1, wsScripts.Columns.Count).End(xlToLeft).Column
    
    ' 遍历每个用户
    For userRow = 2 To lastUserRow
        ' 创建用户专属工作表并命名
        Set wsUser = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
        wsUser.Name = wsUsers.Cells(userRow, 1).Value
        
        ' 复制Scripts表的表头到新工作表
        wsScripts.Range(wsScripts.Cells(1, 1), wsScripts.Cells(1, lastScriptCol)).Copy _
            Destination:=wsUser.Range("A1")
        copyToRow = 2
        
        ' 获取当前用户的所有分配脚本编号范围
        Set userScriptsRng = wsUsers.Range(wsUsers.Cells(userRow, 2), _
            wsUsers.Cells(userRow, wsUsers.Columns.Count).End(xlToLeft))
        
        ' 遍历所有脚本，匹配后复制到用户工作表
        For Each scriptCell In wsScripts.Range(wsScripts.Cells(2, 1), wsScripts.Cells(lastScriptRow, 1))
            If Not userScriptsRng.Find(What:=scriptCell.Value, LookIn:=xlValues, _
                LookAt:=xlWhole, MatchCase:=False) Is Nothing Then
                ' 复制脚本的有效列内容，避免多余空列
                wsScripts.Range(wsScripts.Cells(scriptCell.Row, 1), _
                    wsScripts.Cells(scriptCell.Row, lastScriptCol)).Copy _
                    Destination:=wsUser.Range("A" & copyToRow)
                copyToRow = copyToRow + 1
            End If
        Next scriptCell
    Next userRow
End Sub

关键修改说明 #

• 绑定工作表对象：用wsScripts和wsUsers替代动态的Sheets()调用，避免工作表切换引发的逻辑错误
• 动态获取用户脚本范围：每个用户循环时单独获取其分配的脚本编号列表，确保匹配正确的脚本
• 添加表头复制：自动同步Scripts表的字段表头，让用户工作表结构完整
• 精确复制列范围：只复制Scripts表的有效数据列，避免复制冗余空列
• 循环内更新范围：每次处理新用户时重新初始化脚本匹配范围，解决原代码所有用户共用同一范围的问题

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