在相应列中查找唯一值

Question

选择的前两列比较两列在第二列中找到的任何唯一值，该值复制并粘贴到第二列下方，不需要第一列唯一值，选择的前三列比较这三列在第三列中找到的任何唯一值复制和粘贴粘贴到第三列下方，不需要第一列和第二列唯一值，依此类推....

Answer 1

根据需要更改此公式中的参数：（在单元格 B14 中）并复制到右侧

=UNIQUE(TOCOL(CHOOSECOLS($A$4:$D$10,SEQUENCE(1,COLUMNS($A$14:B$14))),3,TRUE),,TRUE)

注意：现在参考文献与发布的图像相对应。

Answer 2

• 使用字典来统计零件，然后得到唯一零件的列表
• 如果您的表将来扩展，代码可以捕获所有列

微软文档：

Range.Resize 属性 (Excel)

Worksheet.UsedRange 属性 (Excel)

字典对象

Option Explicit

Sub Demo()
    Dim objDic As Object, rngData As Range
    Dim i As Long, j As Long, sKey
    Dim arrData, arrRes, iR As Long
    Const START_ROW = 4
    Set objDic = CreateObject("scripting.dictionary")
    Set rngData = ActiveSheet.UsedRange
    arrData = rngData.Value
    Dim RowCnt As Long: RowCnt = UBound(arrData)
    ' loop through cols
    For j = LBound(arrData) To UBound(arrData, 2)
        ' loop through rows
        For i = START_ROW To RowCnt
            sKey = arrData(i, j)
            If Len(sKey) > 0 Then
                ' count by Dict
                If objDic.exists(sKey) Then
                    objDic(sKey) = objDic(sKey) + 1
                Else
                    objDic(sKey) = 1
                End If
            End If
        Next
        ' Get the unqiue list for 2nd, 3rd ... Cols
        If j > 1 Then
            ReDim arrRes(1 To RowCnt, 0)
            iR = 0
            For Each sKey In objDic.Keys
                ' get the unique list
                If objDic(sKey) = 1 Then
                    iR = iR + 1
                    arrRes(iR, 0) = sKey
                End If
            Next
            ' write output to sheet
            If iR > 0 Then
                Cells(RowCnt + 2, j).Value = iR
                Cells(RowCnt + 3, j).Resize(iR, 1).Value = arrRes
            End If
        End If
    Next
End Sub