Question

我有一个大表，里面有很多数据，但是我要看的是该表的六列-一起从事某项工作的人的名字。像这样：

+-------+--------+--------+-------+--------+-------+
| Name1 | Name2  | Name3  | Name4 | Name5  | Name6 |
+-------+--------+--------+-------+--------+-------+
| Rod   | Jane   |        |       |        |       |
| Jane  | Freddy | Peter  | Paul  |        |       |
| Paul  |        |        |       |        |       |
| Mary  | Jane   | Rod    | Peter | Freddy | Paul  |
| Paul  | Rod    | Freddy |       |        |       |
+-------+--------+--------+-------+--------+-------+

最后我要讲的是这个（在另一张纸上）：

+--------+
|  Name  |
+--------+
| Rod    |
| Jane   |
| Freddy |
| Peter  |
| Paul   |
| Mary   |
+--------+

我希望能够识别出这六列中的所有唯一条目，然后将它们填充到另一张纸上。我的第一个想法是使用公式执行此操作，并且奏效了（我在MATTCH部分中使用INDEX MATCH和COUNTIF），但是表中有11000记录，可能涉及1200多个不同的名称，这占用了大多数要处理的一天。我希望，使用VBA可以使其运行更快。

我研究了许多可能的答案。首先，我去了这里：Populate unique values into a VBA array from Excel，看着brettdj的回答（因为我有点理解它的去向），最后显示了以下代码：

Dim X
Dim objDict As Object
Dim lngRow As Long

Sheets("Data").Select
Set objDict = CreateObject("Scripting.Dictionary")
X = Application.Transpose(Range([be2], Cells(Rows.Count, "BE").End(xlUp)))

For lngRow = 1 To UBound(X, 1)
objDict(X(lngRow)) = 1
Next

Sheets("Crew").Select

Range("A2:A" & objDict.Count) = Application.Transpose(objDict.keys)
End Sub

表现出色，对于一列（BE是上表中的Name1列-数据是存储数据的表，乘员组是我希望唯一值进入的表）。但是我一生都无法找出如何使它从多列（BE到BJ）中获取值。

然后我尝试了此方法，该方法是根据Quicker way to get all unique values of a column in VBA?中的杰里米·汤普森的答案得出的：

Sheets("Data").Select

Range("BE:BJ").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheets("Crew").Range("A:A"), Unique:=True

但是同样，我无法使它将多列中的信息整合为一个。第三次尝试，我查看了How to extract unique values from two columns Excel VBA的Gary的学生答案，并尝试了以下方法：

Dim Na As Long, Nc As Long, Ne As Long
Dim i As Long
Na = Sheets("Stroke Data").Cells(Rows.Count, "BE").End(xlUp).Row
Nc = Sheets("Stroke Data").Cells(Rows.Count, "BF").End(xlUp).Row
Ne = 1

For i = 1 To Na
    Cells(Ne, "E").Value = Cells(i, "A").Value
    Ne = Ne + 1
Next i
For i = 1 To Na
    Cells(Ne, "E").Value = Cells(i, "C").Value
    Ne = Ne + 1
Next i

Sheets("Fail").Range("A:A").RemoveDuplicates Columns:=1, Header:=xlNo

（仅在其中尝试了两列，以查看是否可以通过这种方式找出来，但没有）

我真的很茫然。正如您可能从上面看到的那样，我四处乱窜，并尝试从三个不同的角度来解决这个问题，但是却一无所获。我觉得必须有一种方法可以使第一个工作，即使没有其他事情，因为它几乎可以工作。但是我不明白。

我想我可以将其运行在四个单独的列中，然后执行一个将这四个合并为一个过程。但是即使那样，我仍然不确定如何删除将导致的重复（如您在上表中看到的，名称可以出现在任何列中）。

只要我能以一列唯一名称结尾并且不需要花费数小时来处理，我想我真的不介意如何到达那里。

Answer 1

这将提示您选择一个范围（可以通过按住CTRL键选择一个不连续的范围），然后将从所选范围中提取唯一值并将结果输出到新的工作表上：

Sub tgr()

    Dim wb As Workbook
    Dim wsDest As Worksheet
    Dim rData As Range
    Dim rArea As Range
    Dim aData As Variant
    Dim i As Long, j As Long
    Dim hUnq As Object

    'Prompt to select range.  Uniques will be extracted from the range selected.
    'Can select a non-contiguous range by holding CTRL
    On Error Resume Next
    Set rData = Application.InputBox("Select range of names where unique names will be extracted:", "Data Selection", Selection.Address, Type:=8)
    On Error GoTo 0
    If rData Is Nothing Then Exit Sub   'Pressed cancel

    Set hUnq = CreateObject("Scripting.Dictionary")
    For Each rArea In rData.Areas
        If rArea.Cells.Count = 1 Then
            ReDim aData(1 To 1, 1 To 1)
            aData(1, 1) = rArea.Value
        Else
            aData = rArea.Value
        End If

        For i = 1 To UBound(aData, 1)
            For j = 1 To UBound(aData, 2)
                If Not hUnq.Exists(aData(i, j)) And Len(Trim(aData(i, j))) > 0 Then hUnq(Trim(aData(i, j))) = Trim(aData(i, j))
            Next j
        Next i
    Next rArea

    Set wb = rData.Parent.Parent    'First parent is the range's worksheet, second parent is the worksheet's workbook
    Set wsDest = wb.Sheets.Add(After:=wb.Sheets(wb.Sheets.Count))
    wsDest.Range("A1").Resize(hUnq.Count).Value = Application.Transpose(hUnq.Items)

End Sub

Answer 2

这有点冗长，但是对您的示例数据有用。（可能需要调整初始rng的设置方式。）

Sub unique_names()
Dim rng As Range
Set rng = ActiveSheet.UsedRange

Dim col As Range, cel As Range
Dim names() As Variant
ReDim names(rng.Cells.Count)

Dim i As Long
i = 0
'First, let's add all the names to the array
For Each col In rng.Columns
    For Each cel In col.Cells
        If cel.Value <> "" Then
            names(i) = cel.Value
            i = i + 1
        End If
    Next cel
Next col

' Now, extract unique names from the array
Dim arr As New Collection, a
Set arr = unique_values(names)
For i = 1 To arr.Count
   Worksheets("Sheet1").Cells(i, 10) = arr(i)
Next

End Sub
Private Function unique_values(iArr As Variant) As Collection
' https://stackoverflow.com/a/3017973/4650297
Dim arr As New Collection, a
On Error Resume Next
  For Each a In iArr
     arr.Add a, a
  Next

Set unique_values = arr

End Function

Answer 3

这是使用字典的一种方法。只需指定要搜索的范围，然后RangeToDictionary函数即可完成其余工作。我假设您不想包含空格，所以我删除了这些空格。

Private Function RangeToDictionary(MyRange As Range) As Object
    If MyRange Is Nothing Then Exit Function
    If MyRange.Cells.Count < 1 Then Exit Function

    Dim cell  As Range
    Dim dict  As Object: Set dict = CreateObject("Scripting.Dictionary")

    For Each cell In MyRange
        If Not dict.exists(Trim$(cell.Value2)) And Trim$(cell.Value2) <> vbNullString Then dict.Add cell.Value2, cell.Value2
    Next

    Set RangeToDictionary = dict
End Function

Sub Example()
    Dim dict       As Object
    Dim rng        As Range:Set rng = ThisWorkbook.Sheets("Sheet1").Range("A1:f5")
    Dim outsheet   As Worksheet:Set outsheet = ThisWorkbook.Sheets("Sheet2")

    Set dict = RangeToDictionary(rng)

    outsheet.Range(outsheet.Cells(1, 1), outsheet.Cells(dict.Count, 1)) = Application.Transpose(dict.items())
End Sub

Answer 4

假设您具有Excel 2016及更高版本，则可以使用Power Query进行此操作。将数据范围转换为表，选择表中的单元格，在“数据”>“获取和转换”中选择“来自表”，然后将以下代码粘贴到Power Query Editor的Advanced Editor中（将Table3更改为表名结尾的任何内容）起来）。

let
    Source = Excel.CurrentWorkbook(){[Name="Table3"]}[Content],
    #"Changed Type" = Table.TransformColumnTypes(Source,{{"Name1", type text}, {"Name2", type text}, {"Name3", type text}, {"Name4", type text}, {"Name5", type text}, {"Name6", type text}}),
    #"Replaced Value" = Table.ReplaceValue(#"Changed Type"," ","",Replacer.ReplaceText,{"Name1", "Name2", "Name3", "Name4", "Name5", "Name6"}),
    #"Added Custom" = Table.AddColumn(#"Replaced Value", "Text.Combine", each Text.Combine({[#"Name1"],[#"Name2"],[#"Name3"],[#"Name4"],[#"Name5"],[#"Name6"]},";")),
    #"Replaced Value1" = Table.ReplaceValue(#"Added Custom",";;","",Replacer.ReplaceText,{"Text.Combine"}),
    #"Split Column by Delimiter" = Table.ExpandListColumn(Table.TransformColumns(#"Replaced Value1", {{"Text.Combine", Splitter.SplitTextByDelimiter(";", QuoteStyle.Csv), let itemType = (type nullable text) meta [Serialized.Text = true] in type {itemType}}}), "Text.Combine"),
    #"Changed Type1" = Table.TransformColumnTypes(#"Split Column by Delimiter",{{"Text.Combine", type text}}),
    #"Removed Duplicates" = Table.Distinct(#"Changed Type1", {"Text.Combine"}),
    #"Filtered Rows" = Table.SelectRows(#"Removed Duplicates", each ([Text.Combine] <> "")),
    #"Removed Columns" = Table.RemoveColumns(#"Filtered Rows",{"Name1", "Name2", "Name3", "Name4", "Name5", "Name6"}),
    #"Renamed Columns" = Table.RenameColumns(#"Removed Columns",{{"Text.Combine", "UniqueList"}})
in
    #"Renamed Columns"

如何从多个列中提取唯一值，然后使用它们来填充一列？

4 个答案: