基于筛选条件实现跨工作表数据复制的VBA循环问题

你的代码有几个关键问题，直接导致筛选和复制功能失效：

• 筛选条件错配：需求是匹配A列的division 1，但代码里判断的是"1"，完全不符合
• 复制逻辑混乱：循环里每次都把整列D/F数据粘贴到目标表的A2/B2，不是当前匹配行的单个单元格
• 只硬编码处理了Div 1，其他部门完全没覆盖
• 没有重复检查机制，每周运行会重复录入相同数据

下面是修正后的完整代码，解决了所有问题，还支持扩展多个部门：

Sub CopyDepartmentData()
    Dim wsSource As Worksheet
    Dim wsDest As Worksheet
    Dim lastRowSource As Long
    Dim lastRowDest As Long
    Dim i As Long
    Dim deptMap As Object ' 部门映射：源表部门值 → 目标工作表名
    Dim sourceDept As String
    Dim sourceDVal As String
    Dim isDuplicate As Boolean
    
    ' 初始化部门映射，新增部门直接加行就行
    Set deptMap = CreateObject("Scripting.Dictionary")
    deptMap("division 1") = "Div 1"
    deptMap("division 2") = "Div 2"
    deptMap("division 3") = "Div 3" ' 按需添加更多
    
    Set wsSource = ThisWorkbook.Worksheets("PTP Dash")
    lastRowSource = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
    
    ' 遍历源表每一行（从第2行开始，默认第1行是表头）
    For i = 2 To lastRowSource
        sourceDept = Trim(wsSource.Cells(i, "A").Value)
        sourceDVal = Trim(wsSource.Cells(i, "D").Value)
        
        ' 先确认当前部门有对应的目标工作表
        If deptMap.Exists(sourceDept) Then
            Set wsDest = ThisWorkbook.Worksheets(deptMap(sourceDept))
            lastRowDest = wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Row
            
            ' 检查是否重复：目标表A列有没有当前D列的值
            On Error Resume Next
            isDuplicate = Not IsError(Application.Match(sourceDVal, wsDest.Range("A:A"), 0))
            On Error GoTo 0
            
            ' 不重复才复制
            If Not isDuplicate Then
                wsDest.Cells(lastRowDest + 1, "A").Value = wsSource.Cells(i, "D").Value
                wsDest.Cells(lastRowDest + 1, "B").Value = wsSource.Cells(i, "F").Value
            End If
        End If
    Next i
    
    MsgBox "数据同步完成！", vbInformation
End Sub

关键改进说明 #

• 部门映射表：用Dictionary存对应关系，新增部门只需要加一行deptMap("xxx") = "yyy"，不用改循环逻辑
• 精准单行复制：每次只复制当前匹配行的D/F列，不会像原代码那样整列覆盖
• 重复检查：用Application.Match快速判断目标表是否已有相同数据，避免重复录入
• 动态匹配工作表：自动根据源表部门值找到对应工作表，不用给每个部门写单独的处理代码

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