VBA匹配数组唯一值复制对应行至新工作表故障排查

原有代码错误点 #

• 外层遍历result数组的循环未实际使用，内层Match匹配到任意姓名时，直接将整个数组作为工作表名创建，命名逻辑完全错误
• 未判断对应姓名的工作表是否已存在，每次匹配到数据就新建工作表，导致同一个姓名匹配到多少行就生成多少个仅单条数据的工作表
• LCopyToRow变量未初始化，也没有和对应工作表绑定，粘贴行位置逻辑混乱
• 大量使用Select/Selection类的活跃引用写法，运行效率低且容易出现引用错位

修正后完整代码 #

Sub CopyMatchedRowsToSheets()
    Dim LSearchRow As Long, mtch As Variant
    Dim wsSource As Worksheet, wsTarget As Worksheet
    Dim LCopyToRow As Long
    ' 源数据固定为Sheet1，避免切换工作表导致引用错误
    Set wsSource = ThisWorkbook.Sheets("Sheet1")
    
    LSearchRow = 2
    ' 遍历源表所有有效行
    Do While Len(wsSource.Range("A" & LSearchRow).Value) > 0
        mtch = Application.Match(wsSource.Range("CX" & LSearchRow).Value, result, 0)
        If IsNumeric(mtch) Then
            ' 获取匹配到的姓名
            Dim targetName As String
            targetName = result(mtch - 1) ' Match返回的是1基位置，转成数组的0基索引
            
            ' 判断对应姓名的工作表是否存在，不存在则新建
            On Error Resume Next
            Set wsTarget = ThisWorkbook.Sheets(targetName)
            On Error GoTo 0
            If wsTarget Is Nothing Then
                Set wsTarget = ThisWorkbook.Sheets.Add(after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
                wsTarget.Name = targetName
                ' 新表默认第一行粘贴表头，不需要的可以删除下面这行
                wsSource.Rows(1).Copy wsTarget.Rows(1)
            End If
            
            ' 计算目标表的下一个空白行
            LCopyToRow = wsTarget.Cells(wsTarget.Rows.Count, "A").End(xlUp).Row + 1
            ' 直接复制行，不需要选中
            wsSource.Rows(LSearchRow).Copy wsTarget.Rows(LCopyToRow)
            
            ' 重置目标表变量，避免下一次匹配复用错误
            Set wsTarget = Nothing
        End If
        LSearchRow = LSearchRow + 1
    Loop
End Sub

调整说明 #

• 删掉了无效的外层valCounter2循环，直接遍历源表行进行匹配，逻辑更简洁
• 匹配到姓名后先判断对应工作表是否存在，同一个姓名的所有匹配行都会粘贴到同一个工作表中
• 取消了所有Select操作，直接通过工作表对象引用操作数据，运行更稳定
• 自动计算每个目标表的空白粘贴行，不需要手动维护行计数器

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