VBA实现Tests工作表去重值复制到List工作表的问题排查

原代码的核心问题 #

• 逻辑完全错误：所有条件分支都会执行写入操作，不管当前值和上一个是否重复，导致所有值（包括重复项）都被复制到List表，完全达不到去重目的。
• 依赖单元格激活/选择：Activate和Select操作效率低且易引发逻辑混乱，循环中cell变量与实际激活单元格可能不同步。
• 固定循环范围：硬编码循环到A1019，数据量变化时会出错。
• 未处理工作表已存在的情况：若已有List工作表，Sheets.Add.Name = "List"会直接报错。
• 首行判断漏洞：当cell=2时对比A2与A1，若A1为空，StrComp会抛出错误。

改进方案1：修正遍历逻辑 #

保留遍历思路，仅写入未在List表中出现过的值：

Option Explicit

Sub Main()
    Dim wsTests As Worksheet, wsList As Worksheet
    Dim lastRow As Long, i As Long, listRow As Long
    Dim currentVal As Variant
    Dim isDuplicate As Boolean
    
    ' 初始化工作表对象
    Set wsTests = ThisWorkbook.Sheets("Tests")
    ' 检查List工作表是否存在，不存在则创建
    On Error Resume Next
    Set wsList = ThisWorkbook.Sheets("List")
    On Error GoTo 0
    If wsList Is Nothing Then
        Set wsList = ThisWorkbook.Sheets.Add
        wsList.Name = "List"
    End If
    
    ' 获取Tests表A列最后一行
    lastRow = wsTests.Cells(wsTests.Rows.Count, "A").End(xlUp).Row
    listRow = 1 ' List表的起始行
    
    ' 遍历Tests表A列（假设A1是表头，从A2开始）
    For i = 2 To lastRow
        currentVal = wsTests.Cells(i, "A").Value
        isDuplicate = False
        
        ' 检查当前值是否已在List表中存在
        If listRow > 1 Then
            If Not wsList.Range("A1:A" & listRow - 1).Find(currentVal, LookIn:=xlValues, LookAt:=xlWhole) Is Nothing Then
                isDuplicate = True
            End If
        End If
        
        ' 非重复则写入List表
        If Not isDuplicate Then
            wsList.Cells(listRow, "A").Value = currentVal
            listRow = listRow + 1
        End If
    Next i
End Sub

改进方案2：使用字典去重（高效适配大数据） #

利用字典键的唯一性快速去重：

Option Explicit

Sub UniqueValuesWithDictionary()
    Dim wsTests As Worksheet, wsList As Worksheet
    Dim lastRow As Long, i As Long
    Dim dict As Object
    Dim currentVal As Variant
    
    Set wsTests = ThisWorkbook.Sheets("Tests")
    ' 处理List工作表
    On Error Resume Next
    Set wsList = ThisWorkbook.Sheets("List")
    On Error GoTo 0
    If wsList Is Nothing Then
        Set wsList = ThisWorkbook.Sheets.Add
        wsList.Name = "List"
    End If
    
    ' 创建字典对象，不区分大小写
    Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
    
    lastRow = wsTests.Cells(wsTests.Rows.Count, "A").End(xlUp).Row
    
    ' 遍历Tests表，将非重复值存入字典
    For i = 2 To lastRow
        currentVal = wsTests.Cells(i, "A").Value
        If Not IsEmpty(currentVal) Then ' 跳过空值
            If Not dict.Exists(currentVal) Then
                dict.Add currentVal, ""
            End If
        End If
    Next i
    
    ' 将字典的键写入List表
    If dict.Count > 0 Then
        wsList.Range("A1").Resize(dict.Count).Value = Application.Transpose(dict.Keys)
    End If
End Sub

改进方案3：利用Excel内置功能（最简实现） #

直接调用Excel原生的删除重复项功能：

Option Explicit

Sub UniqueValuesWithExcelFeature()
    Dim wsTests As Worksheet, wsList As Worksheet
    Dim lastRow As Long
    
    Set wsTests = ThisWorkbook.Sheets("Tests")
    ' 处理List工作表
    On Error Resume Next
    Set wsList = ThisWorkbook.Sheets("List")
    On Error GoTo 0
    If wsList Is Nothing Then
        Set wsList = ThisWorkbook.Sheets.Add
        wsList.Name = "List"
    End If
    
    ' 复制Tests表A列数据到List表
    lastRow = wsTests.Cells(wsTests.Rows.Count, "A").End(xlUp).Row
    wsTests.Range("A2:A" & lastRow).Copy wsList.Range("A1")
    
    ' 删除重复项
    wsList.Range("A:A").RemoveDuplicates Columns:=1, Header:=xlNo
End Sub

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