如何用VBA结合去重与数组实现按首列过滤并跨表调用指定列？

你的现有代码存在几个关键问题：未明确数据源工作表（依赖活动表易出错）、直接修改原表数据、未实现指定列顺序导出的需求。以下是优化后的实现方案：

核心思路 #

1. 明确指定数据源工作表，避免活动表切换导致的错误
2. 先基于第一列提取唯一值，保留对应行的其他列数据
3. 按需求的列顺序，将处理后的数据导出到新工作表中

完整VBA代码（复制粘贴版，易上手） #

Sub FilterAndExportUnique()
    Dim srcSheet As Worksheet
    Dim destSheet As Worksheet
    Dim lastRow As Long
    
    ' 指定数据源工作表（改成你的实际数据所在表名，比如Sheet1）
    Set srcSheet = ThisWorkbook.Worksheets("Sheet1")
    ' 创建新工作表存结果
    Set destSheet = ThisWorkbook.Worksheets.Add(After:=srcSheet)
    destSheet.Name = "Unique_Result"
    
    ' 获取数据源最后一行
    lastRow = srcSheet.Cells(srcSheet.Rows.Count, 1).End(xlUp).Row
    ' 复制原数据到新表（不破坏原始数据）
    srcSheet.Range("A1:F" & lastRow).Copy destSheet.Range("A1")
    
    ' 在新表中基于第一列去重
    destSheet.Range("A1:F" & lastRow).RemoveDuplicates Columns:=1, Header:=xlYes
    
    ' 按指定顺序重新排列列（示例：保留第1、5、3列，顺序为1→5→3）
    Dim desiredColumns As Variant
    desiredColumns = Array(1, 5, 3) ' 替换成你需要的列序号
    Dim colIndex As Integer, targetCol As Integer
    
    targetCol = 1
    For Each colIndex In desiredColumns
        destSheet.Columns(colIndex).Copy
        destSheet.Columns(targetCol).PasteSpecial xlPasteValuesAndNumberFormats
        targetCol = targetCol + 1
    Next colIndex
    
    ' 删除多余列（根据实际情况调整范围）
    destSheet.Range("D:F").Delete Shift:=xlToLeft
    
    ' 清理剪贴板
    Application.CutCopyMode = False
End Sub

代码说明 #

• 数据源指定：把Sheet1改成你的实际数据所在工作表名称
• 列顺序自定义：修改desiredColumns = Array(1,5,3)中的数字，对应原表列序号（A列=1，B列=2，以此类推）
• 保护原数据：先复制原数据到新表再去重，不会修改原始数据
• 格式保留：用xlPasteValuesAndNumberFormats确保导出数据的格式和原表一致

大数据量优化版（数组处理，效率更高） #

如果你的数据量很大，用数组直接处理会更快：

Sub ArrayBasedUniqueExport()
    Dim srcSheet As Worksheet
    Dim destSheet As Worksheet
    Dim lastRow As Long
    Dim dataArr As Variant
    Dim uniqueDict As Object
    Dim i As Long, j As Long
    Dim desiredCols As Variant
    Dim outputArr As Variant
    Dim outRow As Long
    
    Set srcSheet = ThisWorkbook.Worksheets("Sheet1")
    Set destSheet = ThisWorkbook.Worksheets.Add(After:=srcSheet)
    destSheet.Name = "Array_Result"
    desiredCols = Array(1, 3, 5) ' 指定需要的列序号
    Set uniqueDict = CreateObject("Scripting.Dictionary")
    
    ' 读取原数据到数组
    lastRow = srcSheet.Cells(srcSheet.Rows.Count, 1).End(xlUp).Row
    dataArr = srcSheet.Range("A1:F" & lastRow).Value
    
    ' 初始化输出数组
    ReDim outputArr(1 To UBound(dataArr, 1), 1 To UBound(desiredCols) + 1)
    outRow = 1
    
    ' 写入表头
    For i = 0 To UBound(desiredCols)
        outputArr(outRow, i + 1) = dataArr(1, desiredCols(i))
    Next i
    outRow = outRow + 1
    
    ' 遍历提取唯一值及指定列数据
    For i = 2 To UBound(dataArr, 1)
        If Not uniqueDict.Exists(dataArr(i, 1)) Then
            uniqueDict.Add dataArr(i, 1), True
            ' 按指定顺序写入数据
            For j = 0 To UBound(desiredCols)
                outputArr(outRow, j + 1) = dataArr(i, desiredCols(j))
            Next j
            outRow = outRow + 1
        End If
    Next i
    
    ' 将数组写入结果表
    destSheet.Range("A1").Resize(outRow - 1, UBound(desiredCols) + 1).Value = outputArr
End Sub

这个版本通过字典去重+数组读写，避免了大量单元格操作，处理十万级数据也不会卡顿，同样修改desiredCols数组即可自定义列顺序。

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