从表生成唯一列表

Question

我在表格的最左列中有一个姓名列表，并在各自的列中输入了 1 到 4 种语言（lang1、lang2、lang3、lang4）。我想创建一个区域，可以在其中的六个单元格中输入姓名，然后会生成一个相邻的列表，其中包含这组人所掌握的所有语言。

本质上，我希望 Excel 比较六个 1 行 4 列的数组，并返回任意适当长度的单列数组。六个数组中值的并集。

这是我为了帮助解释而创建的没有公式的示例。

我需要生成一个列表，列出少于或等于 6 人的小组能够说的所有语言。如果 Jacob 是列表中唯一的一个人，那么列表将简单地显示“英语、西班牙语、葡萄牙语”。如果列表仅由 Jacob 和 Sally 组成，则将显示“英语、西班牙语、葡萄牙语、法语”。

如果需要，我可以更改表格的设置。例如，最初每种语言都是一列，用 X 或 Y 作为标志来表示该人是否懂该语言。我认为目前这种方式可能更简单。

谢谢！任何帮助我都感激不尽！

Answer 1

我无法想出公式，但您可以使用 VBA 宏来执行此操作。您必须触发宏才能运行。

如果您不熟悉，要输入此宏（子），alt-F11请打开 Visual Basic 编辑器。确保您的项目在 Project Explorer 窗口中突出显示。然后，从顶部菜单中选择插入/模块并将以下代码粘贴到打开的窗口中。

要使用此宏（子），alt-F8请打开宏对话框。按名称选择宏，然后RUN。

宏假定您的姓名/语言表从 A1 开始，并且您的Names列位于第 1 行的某个位置。并且该列的标题必须是Names。在宏中，可以通过多种方式进行更改。

此外，你还必须确保WS指的是正确的工作表。

Option Explicit
Sub langsKnown()
    Dim WS As Worksheet
    Dim vSrc As Variant, vNames As Variant, vLangs As Variant
    Dim rLangs As Range, C As Range
    Dim dLangs As Object, dNames As Object
    Dim V
    Dim I As Long, J As Long
    Dim sLang As String

Set WS = Worksheets("sheet4") 'or whatever

'Read language table into variant array
'  many ways to do this
'  Assuming it starts in **A1**'
vSrc = WS.Cells(1, 1).CurrentRegion

'Read Names into array
With WS.Rows(1)
    'Find the Names column
    'Assuming it starts in Row 1
    Set C = .Find(what:="Names", after:=.Cells(1, 1), LookIn:=xlValues, lookat:=xlWhole, _
                    searchorder:=xlByRows, searchdirection:=xlNext, MatchCase:=True)
    If Not C Is Nothing Then
        Set rLangs = C.Offset(0, 1)
        With WS
            vNames = .Range(C.Offset(1, 0), .Cells(.Rows.Count, C.Column).End(xlUp))
            If Not IsArray(vNames) Then 'this will be true when there is only a single name
                V = vNames
                ReDim vNames(1 To 1, 1 To 1)
                vNames(1, 1) = V
            End If
        End With
        If IsEmpty(vNames(1, 1)) Then
            MsgBox "No Names"
            Exit Sub
        End If

        'Read Names into dictionary for easy lookups
        Set dNames = CreateObject("Scripting.Dictionary")
            dNames.comparemode = vbTextCompare
        For Each V In vNames
            If Not dNames.exists(V) Then _
                dNames.Add V, V
        Next V
    Else
        MsgBox "No Names"
        Exit Sub
    End If
End With

'Collect relevant languages into dictionary
Set dLangs = CreateObject("Scripting.Dictionary")
    dLangs.comparemode = vbTextCompare

For I = 2 To UBound(vSrc, 1)
    If dNames.exists(vSrc(I, 1)) Then
        For J = 2 To UBound(vSrc, 2)
            sLang = vSrc(I, J)
            If Len(sLang) > 0 And Not dLangs.exists(sLang) Then _
                dLangs.Add sLang, sLang
        Next J
    End If
Next I

'write results to VBA array
ReDim vLangs(0 To dLangs.Count, 1 To 1)

'Header
vLangs(0, 1) = "Languages Spoken by Group"

'Data
I = 0
For Each V In dLangs.keys
    I = I + 1
    vLangs(I, 1) = V
Next V

'Write to the worksheet
Set rLangs = rLangs.Resize(rowsize:=UBound(vLangs, 1) + 1)
With rLangs
    .EntireColumn.Clear
    .Value = vLangs
    .Rows(1).Font.Bold = True
    With .EntireColumn
        .AutoFit
        .HorizontalAlignment = xlCenter
    End With
End With

End Sub