Excel VBA宏求助：如何在计数同时将符合条件值列至AD列

核心修改思路 #

原代码用字符串拼接存储唯一值，数据量大时极易导致性能下降甚至崩溃。改用Collection集合存储唯一值，既自动去重又提升稳定性，同时方便后续批量输出到AD列。

修改后的完整代码 #

Sub CountAndListUniqueValues()
    Dim myTbl As Range, xCol As Long
    Dim uniqueCol As New Collection
    Dim Miss As Long, i As Long
    Dim ws As Worksheet
    
    ' 指定目标工作表，避免因激活工作表变化出错
    Set ws = ThisWorkbook.Sheets("OB")
    
    ' 定义数据范围：从AE2到AE列最后一行，同时包含AH列
    Set myTbl = ws.Range("AE2:AH" & ws.Cells(ws.Rows.Count, "AE").End(xlUp).Row)
    xCol = 4 ' AH列在myTbl中的列序号（AE为第1列，AH为第4列）
    
    ' 清空AD列原有数据（从AD2开始）
    ws.Range("AD2:AD" & ws.Cells(ws.Rows.Count, "AD").End(xlUp).Row).ClearContents
    
    ' 遍历数据，筛选符合条件的唯一值
    On Error Resume Next ' 捕获集合重复项添加错误
    For i = 1 To myTbl.Rows.Count
        If myTbl.Cells(i, 1).Value <> "" Then ' AE列不为空
            If myTbl.Cells(i, xCol).Value <> "OB" Then ' AH列不为"OB"
                ' 添加到集合，用值作为键实现自动去重
                uniqueCol.Add myTbl.Cells(i, 1).Value, Key:=CStr(myTbl.Cells(i, 1).Value)
                If Err.Number = 0 Then ' 无错误说明是新的唯一值
                    Miss = Miss + 1
                End If
                Err.Clear ' 重置错误状态
            End If
        End If
    Next i
    On Error GoTo 0 ' 恢复正常错误捕获
    
    ' 更新K2的统计结果
    With ws.Range("K2")
        If Miss > 0 Then
            .Value = Miss & " still active"
            .Font.ColorIndex = 46
        Else
            .Value = "None"
            .Font.ColorIndex = 10
        End If
    End With
    
    ' 将唯一值输出到AD列（从AD2开始）
    If Miss > 0 Then
        For i = 1 To uniqueCol.Count
            ws.Cells(i + 1, "AD").Value = uniqueCol(i)
        Next i
    End If
End Sub

关键修改点说明 #

• 替换存储方式：用Collection替代字符串拼接，彻底解决长字符串导致的性能问题和崩溃风险，集合通过Key参数自动去重。
• 明确工作表对象：直接绑定目标工作表，避免因当前激活工作表变化引发的逻辑错误。
• 清空AD列旧数据：提前清除AD列原有内容，保证输出结果无残留。
• 批量输出唯一值：遍历集合将筛选出的唯一值写入AD列，从AD2开始向下填充。

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