从跨越多列的名称范围编译不同值的列表

Posted 2023-02-19

【中文标题】从跨越多列的名称范围编译不同值的列表

【英文标题】：Compile a list of distinct values from a name range that spans multiple columns

【发布时间】：2021-08-12 15:26:55

【问题描述】：

我正在尝试将命名范围“WESupplierALL”中的不同值列表编译到单个列中。 我已经尝试过独特和高级的过滤器功能，但我似乎可以破解它。 有任何想法吗？我对所有选项持开放态度，包括 VBA、公式等。

【问题讨论】：

在 *** 中查看这篇文章。 Excel UNIQUE Across Columns

这能回答你的问题吗？ Excel VBA Dictionary Storing and Retrieving - VBA 中的 Dictionary object 可用于存储唯一键（值），这对于在数据集中查找 1 个重复数据实例很有用。

您是否只想列出上图中 A2:M10 中的唯一值？

【参考方案1】：

根据 cmets（链接）中的建议，您可以使用 TEXTJOIN 和 FILTERXML 的组合，但公式很长，会影响可读性。 Power Query 是另一种选择。

多年来，我使用自己的 VBA 函数来统一价值观。您可以使用我的存储库中的DM_ARRAY 函数：VBA-ArrayTools。有一个演示工作簿可用，您将找到每个用户定义函数 (UDF) 的专用工作表。对于DM_ARRAY，第一个参数是您想要作为输出的列数，然后您可以根据需要传递任意数量的范围。在您的情况下，您可以使用=UNIQUE(DM_ARRAY(1,E2:E23,I2:I23,M2:M23)) 获得所需的结果。当然你可以传递一个命名范围，比如=UNIQUE(DM_ARRAY(1,WESupplierALL))。

此外，如果您想在没有高级数组公式的另一台计算机上获得相同的结果，那么同一个库有一个您可以使用的 DM_UNIQUE 函数。

【参考方案2】：

将唯一值从多列写入一列

调整（使用）常量部分和工作簿中的值。

Option Explicit

Sub writeUnique()
    
    Const wsName As String = "Sheet1"
    Const ColsList As String = "E,I,M"
    Const fRow As Long = 2
    Const lRow As Long = 23
    Const dFirst As String = "A2"
        
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim Cols() As String: Cols = Split(ColsList, ",")
    Dim rCount As Long: rCount = lRow - fRow + 1
    
    Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare ' ignore case
      
    Dim crg As Range
    Dim Data As Variant
    Dim Key As Variant
    Dim r As Long, n As Long
    
    For n = 0 To UBound(Cols)
        Set crg = ws.Columns(Cols(n)).Resize(rCount).Offset(fRow - 1)
        Data = crg.Value
        For r = 1 To rCount
            Key = Data(r, 1)
            If Not IsError(Key) Then ' ignore error values
                If Len(Key) > 0 Then ' ignore blanks
                    dict(Key) = Empty
                End If
            End If
        Next r
    Next n
    
    If dict.Count = 0 Then Exit Sub
    
    ReDim Data(1 To dict.Count, 1 To 1)
    r = 0
    
    For Each Key In dict.Keys
        r = r + 1
        Data(r, 1) = Key
    Next Key
    
    With ws.Range(dFirst)
        .Resize(r).Value = Data
        .Resize(.Worksheet.Rows.Count - .Row - r + 1).Offset(r).ClearContents
    End With
    
End Sub