VBA项目问题：如何实现Segment ID去重并仅输出唯一值？

当前我在开发VBA项目的最后一项功能，需要实现忽略重复的Segment ID，每个唯一值仅显示一次。在PJK工作表中，A列的某个Item可能对应B列的同一个Segment ID出现多次（比如Item X对应Segment _03出现3次），但输出时只需要显示该Segment ID一次。

以下是当前存在问题的去重代码：

Sub FilterAndOutputV7_2S()
    Dim wsPJK As Worksheet
    Dim wsCommonParts As Worksheet
    Dim rngCommonParts As Range
    Dim outputCell As Range
    Dim commonPart As Range
    Dim filteredData As Range
    Dim itemNumber As Variant
    Dim lastRow As Long
    Dim uniqueValues As Object ' Use Dictionary object
    Dim cellValue As Variant
    Dim outputRange As Range
    
    ' Set your worksheet references
    Set wsPJK = ThisWorkbook.Sheets("PJK")
    Set wsCommonParts = ThisWorkbook.Sheets("Common Parts")
    
    ' Set the range in Common Parts sheet where you want to loop through item numbers
    Set rngCommonParts = wsCommonParts.Range("A2:A" & wsCommonParts.Cells(wsCommonParts.Rows.Count, "A").End(xlUp).Row)
    
    ' Initialize output starting cell
    Set outputCell = wsCommonParts.Range("B2")
    
    ' Loop through each cell in the Common Parts sheet's range
    For Each commonPart In rngCommonParts
        ' Get the item number from Common Parts sheet
        itemNumber = commonPart.Value
        
        ' Find the last row in column B of PJK sheet
        lastRow = wsPJK.Cells(wsPJK.Rows.Count, "B").End(xlUp).Row
        
        ' Filter data in PJK sheet based on the current item number
        wsPJK.Range("A:B").AutoFilter Field:=1, Criteria1:=itemNumber
        
        ' Check if there are visible cells in column B (excluding header)
        On Error Resume Next
        Set filteredData = wsPJK.Range("B2:B" & lastRow).SpecialCells(xlCellTypeVisible)
        On Error GoTo 0
        
        ' Initialize Dictionary object to store unique values
        Set uniqueValues = CreateObject("Scripting.Dictionary")
        
        ' Output the filtered data to the Common Parts sheet (left-aligned) without duplicates
        outputCell.Value = itemNumber
        Set outputRange = outputCell.Offset(0, 1)
        
        If Not filteredData Is Nothing Then
            For Each cellValue In filteredData
                On Error Resume Next
                uniqueValues.Add cellValue.Value, CStr(cellValue.Value)
                On Error GoTo 0
            Next cellValue
            
            ' Output unique values to the next columns and left-align
            outputRange.Resize(uniqueValues.Count, 1).Value = Application.WorksheetFunction.Transpose(uniqueValues.Keys)
            outputRange.HorizontalAlignment = xlLeft
        End If
        
        Application.CutCopyMode = False
        
        ' Clear the filter in PJK sheet
        wsPJK.AutoFilterMode = False
        
        ' Move the output cell to the next row with a cell break
        Set outputCell = outputCell.Offset(IIf(filteredData Is Nothing, 1, uniqueValues.Count + 2), 0)
    Next commonPart
End Sub

问题分析与修复方案 #

原代码的去重逻辑依赖错误处理来跳过重复添加，容易掩盖潜在问题，且未处理因空格导致的“伪重复”。以下是优化后的代码，确保仅输出唯一的Segment ID：

Sub FilterAndOutputUniqueSegments()
    Dim wsPJK As Worksheet
    Dim wsCommonParts As Worksheet
    Dim rngCommonParts As Range
    Dim outputCell As Range
    Dim commonPart As Range
    Dim filteredRows As Range
    Dim itemNumber As Variant
    Dim lastRow As Long
    Dim uniqueSegments As Object
    Dim cell As Range
    
    ' 设置工作表引用
    Set wsPJK = ThisWorkbook.Sheets("PJK")
    Set wsCommonParts = ThisWorkbook.Sheets("Common Parts")
    
    ' 获取Common Parts中需要处理的Item范围
    Set rngCommonParts = wsCommonParts.Range("A2:A" & wsCommonParts.Cells(wsCommonParts.Rows.Count, "A").End(xlUp).Row)
    
    ' 初始化输出起始单元格
    Set outputCell = wsCommonParts.Range("B2")
    
    ' 创建字典实例，设置不区分大小写（按需调整）
    Set uniqueSegments = CreateObject("Scripting.Dictionary")
    uniqueSegments.CompareMode = vbTextCompare
    
    For Each commonPart In rngCommonParts
        itemNumber = commonPart.Value
        uniqueSegments.RemoveAll ' 清空字典，处理下一个Item
        
        ' 获取PJK表的最后一行
        lastRow = wsPJK.Cells(wsPJK.Rows.Count, "B").End(xlUp).Row
        
        ' 应用筛选
        wsPJK.Range("A:B").AutoFilter Field:=1, Criteria1:=itemNumber
        
        ' 获取可见行（排除表头）
        On Error Resume Next
        Set filteredRows = wsPJK.Range("B2:B" & lastRow).SpecialCells(xlCellTypeVisible)
        On Error GoTo 0
        
        ' 写入当前Item到输出单元格
        outputCell.Value = itemNumber
        
        If Not filteredRows Is Nothing Then
            ' 遍历筛选后的单元格，添加唯一值到字典
            For Each cell In filteredRows
                Dim segValue As String
                segValue = Trim(cell.Value) ' 去除前后空格，避免伪重复
                If segValue <> "" And Not uniqueSegments.Exists(segValue) Then
                    uniqueSegments.Add segValue, segValue
                End If
            Next cell
            
            ' 输出唯一Segment ID到右侧列，左对齐
            With outputCell.Offset(0, 1).Resize(uniqueSegments.Count, 1)
                .Value = Application.WorksheetFunction.Transpose(uniqueSegments.Keys)
                .HorizontalAlignment = xlLeft
            End With
            
            ' 移动输出单元格到下一个Item的位置（空一行分隔）
            Set outputCell = outputCell.Offset(uniqueSegments.Count + 2, 0)
        Else
            ' 无匹配Segment时，直接下移一行
            Set outputCell = outputCell.Offset(1, 0)
        End If
        
        ' 清除筛选
        wsPJK.AutoFilterMode = False
    Next commonPart
End Sub

关键改进点 #

• 字典逻辑优化：显式检查值是否存在，替代错误处理，逻辑更清晰
• 值预处理：添加Trim()去除前后空格，避免因空格导致的重复
• 效率提升：字典创建移到循环外，仅在每次循环前清空，减少对象创建开销
• 输出控制：用With语句简化格式设置，代码更简洁

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