你的需求非常合理，硬编码确实在工作表数量增多后会变得难以维护。下面我会给出基于映射表的动态匹配方案，用字典来存储ID和分组（工作表名）的对应关系，彻底解决扩展性问题。

核心思路 #

1. 先把映射表中的ColA_id和ColB_group数据加载到字典中，这样后续查找匹配关系的效率会非常高
2. 遍历主表C列的每行数据，通过字典快速找到对应的目标工作表名
3. 如果找到匹配的工作表就复制该行，找不到就统一复制到NA工作表
4. 增加工作表存在性判断，避免因映射表中存在不存在的工作表名而报错

优化后的完整代码 #

Sub CopyRowsByMapping()
    Dim wsMaster As Worksheet
    Dim wsMapping As Worksheet
    Dim wsTarget As Worksheet
    Dim wsNA As Worksheet
    Dim dictMapping As Object
    Dim lastRowMaster As Long
    Dim lastRowMapping As Long
    Dim i As Long
    Dim targetSheetName As Variant
    
    ' 定义各个工作表对象（根据你的实际表名修改）
    Set wsMaster = ThisWorkbook.Worksheets("主工作表") ' 替换成你的主表名
    Set wsMapping = ThisWorkbook.Worksheets("映射表") ' 替换成你的映射表名
    On Error Resume Next
    Set wsNA = ThisWorkbook.Worksheets("NA")
    On Error GoTo 0
    If wsNA Is Nothing Then
        ' 如果NA工作表不存在，新建一个
        Set wsNA = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
        wsNA.Name = "NA"
    End If
    
    ' 创建字典存储映射关系
    Set dictMapping = CreateObject("Scripting.Dictionary")
    dictMapping.CompareMode = vbTextCompare ' 不区分大小写，按需调整
    
    ' 加载映射表数据到字典（ColA_id在A列，ColB_group在B列）
    lastRowMapping = wsMapping.Cells(wsMapping.Rows.Count, "A").End(xlUp).Row
    For i = 2 To lastRowMapping ' 假设第一行是表头
        If Not dictMapping.Exists(wsMapping.Cells(i, "A").Value) Then
            dictMapping.Add wsMapping.Cells(i, "A").Value, wsMapping.Cells(i, "B").Value
        End If
    Next i
    
    ' 遍历主表数据行（假设从第3行开始，C列是匹配列）
    lastRowMaster = wsMaster.Cells(wsMaster.Rows.Count, "C").End(xlUp).Row
    Application.ScreenUpdating = False ' 关闭屏幕更新提升速度
    For i = 3 To lastRowMaster
        targetSheetName = dictMapping(wsMaster.Cells(i, "C").Value)
        
        ' 判断是否找到匹配的工作表名
        If Not IsError(targetSheetName) Then
            On Error Resume Next
            Set wsTarget = ThisWorkbook.Worksheets(targetSheetName)
            On Error GoTo 0
            If Not wsTarget Is Nothing Then
                ' 复制行到目标工作表的最后一行下方
                wsMaster.Rows(i).Copy Destination:=wsTarget.Cells(wsTarget.Rows.Count, "A").End(xlUp).Offset(1)
            Else
                ' 映射表中的工作表不存在，转到NA表
                wsMaster.Rows(i).Copy Destination:=wsNA.Cells(wsNA.Rows.Count, "A").End(xlUp).Offset(1)
            End If
        Else
            ' 主表C列的值在映射表中无匹配，转到NA表
            wsMaster.Rows(i).Copy Destination:=wsNA.Cells(wsNA.Rows.Count, "A").End(xlUp).Offset(1)
        End If
    Next i
    
    Application.ScreenUpdating = True ' 恢复屏幕更新
    MsgBox "数据复制完成！", vbInformation
End Sub

关键细节说明 #

• 字典的使用：字典是VBA中处理键值对匹配的高效工具，比多次遍历映射表快得多，尤其数据量大的时候优势明显
• 工作表存在性检查：通过On Error Resume Next捕获工作表不存在的情况，避免宏运行报错
• 屏幕更新关闭：复制大量行时关闭屏幕更新可以大幅提升运行速度
• 可扩展性：后续只要在映射表中新增ColA_id和ColB_group的对应关系，宏不需要做任何修改就能自动适配，完全支持50+工作表的场景

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