VBA跨表复制值时隔列比对去重功能失效问题咨询

你当前代码去重逻辑不生效的核心原因有4个：

• RemoveDuplicates默认逻辑是判断同一行内指定列的组合值是否重复，无法直接实现跨列比对不同列的重复值需求
• RemoveDuplicates的Columns参数是相对于调用方法的Range的内部列序号，不是工作表全局列号，你传入的Array(10,14,18,22,26)和实际数据所在列不匹配
• 调用去重时依赖ActiveSheet定位表，复制操作过程中焦点一旦切换，就会在错误的工作表上执行去重
• 你粘贴到CRSts表的数据分散在间隔列，列间存在大量空列空行，UsedRange会把空值全部纳入判断，导致大量空值被判定为重复项误删，还会跳过实际有数据的区域

方案1：修正内置RemoveDuplicates调用（适合判定同行列组合重复的场景） #

如果你需要的去重规则是「同一行的J、N、R、V、Z列值完全一致时判定为重复、保留首行」，不需要改整体逻辑，只需要修正范围和参数即可，替换原有最后一行去重代码：

' 显式指定目标工作表，不依赖ActiveSheet
Dim wsTarget As Worksheet
Set wsTarget = ThisWorkbook.Sheets("CRSts")
' 明确指定数据范围，不要用UsedRange
' 注意：Range内的列序号从所选范围的第一列开始计数，J列是范围第1列、N是第5列、R是第9列、V是第13列、Z是第17列
wsTarget.Range("J3:Z" & wsTarget.Cells(wsTarget.Rows.Count, "Z").End(xlUp).Row) _
    .RemoveDuplicates Columns:=Array(1, 5, 9, 13, 17), Header:=xlNo

方案2：归集数据后单列去重（适合提取所有列唯一值清单的场景） #

如果你需要的是把5个间隔列的所有值合并后去掉重复项，输出统一的唯一值列表，可以先把分散数据归集到临时列再去重，逻辑稳定不会出错：

Dim wsTarget As Worksheet
Dim lastRow As Long, tmpCol As Long, colNum As Variant
Set wsTarget = ThisWorkbook.Sheets("CRSts")
' 找表内未使用的空列作为临时存储，避免覆盖现有数据
tmpCol = wsTarget.Cells(1, wsTarget.Columns.Count).End(xlToLeft).Column + 1

' 遍历5个目标列，将非空值归集到临时列
For Each colNum In Array(10, 14, 18, 22, 26)
    lastRow = wsTarget.Cells(wsTarget.Rows.Count, colNum).End(xlUp).Row
    If lastRow >= 3 Then
        wsTarget.Range(wsTarget.Cells(3, colNum), wsTarget.Cells(lastRow, colNum)).Copy _
            Destination:=wsTarget.Cells(wsTarget.Rows.Count, tmpCol).End(xlUp).Offset(1, 0)
    End If
Next

' 对临时列执行单列去重
lastRow = wsTarget.Cells(wsTarget.Rows.Count, tmpCol).End(xlUp).Row
If lastRow >= 2 Then
    wsTarget.Range(wsTarget.Cells(2, tmpCol), wsTarget.Cells(lastRow, tmpCol)) _
        .RemoveDuplicates Columns:=1, Header:=xlNo
End If

' 去重完成后可将临时列的结果放回目标位置，最后清空临时列
' wsTarget.Columns(tmpCol).ClearContents

方案3：字典逐值比对去重（适合保留分列结构、跨列删重复值的场景） #

如果你需要保留原有J、N、R、V、Z的分列结构，只删除在任意其他列已经出现过的重复值，用字典对象做逐值判断灵活度最高，不会受空列、位置偏移影响：

Dim wsTarget As Worksheet
Dim i As Long, lastRow As Long, currentVal As String, colNum As Variant
Dim existDict As Object
Set existDict = CreateObject("Scripting.Dictionary")
Set wsTarget = ThisWorkbook.Sheets("CRSts")

' 从左到右遍历列，先出现的值保留，后出现的重复值删除
For Each colNum In Array(10, 14, 18, 22, 26)
    lastRow = wsTarget.Cells(wsTarget.Rows.Count, colNum).End(xlUp).Row
    ' 从下往上遍历行，避免删除行导致行号偏移
    For i = lastRow To 3 Step -1
        currentVal = Trim(wsTarget.Cells(i, colNum).Value)
        If currentVal <> "" Then
            If existDict.Exists(currentVal) Then
                ' 重复值可选择清空单元格，或删除整行
                wsTarget.Cells(i, colNum).Delete Shift:=xlUp
            Else
                existDict.Add currentVal, ""
            End If
        End If
    Next
Next
Set existDict = Nothing

配套优化建议 #

• 删掉代码里所有Select、Selection、ActiveSheet的写法，直接显式指定工作表和Range对象操作，比如复制可以直接写Sheets("SpExtra").Columns("A:B").Copy Sheets("CRToday").Range("A1")，不需要先选表再选区域，避免焦点切换导致操作对象错误
• 代码执行前加Application.ScreenUpdating = False，执行完加Application.ScreenUpdating = True，大幅提升运行速度，也避免界面跳转导致的ActiveSheet偏移
• 跨表粘贴如果只需要值，统一用PasteSpecial xlPasteValues，不要直接用Paste，避免把原表的公式、格式带过去干扰值判断

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