如何從多個列中提取唯一值並使用它們填充一列？

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可以使其運行更快。

我研究了許多可能的答案。 首先，我去了： 從Excel中將唯一值填充到VBA數組中 ，然后查看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列-Data是存儲數據的工作表，Crew是我要使用唯一值的工作表）。 但是我無法終生想出如何使它從多個列（BE到BJ）中獲取值。

然后，我嘗試以快速方式從傑里米·湯普森（Jeremy Thompson）的答案派生出來， 以獲取VBA中列的所有唯一值？ ：

Sheets("Data").Select

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

但同樣，我無法將多列信息整合為一列。 第三次嘗試，我看了如何從兩列Excel VBA中提取唯一值的 Gary的Student答案，並嘗試了以下方法：

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

（在那一欄中只嘗試了兩列，以查看是否可以通過這種方式找出來，但沒有）

我真的很茫然。 正如您可能從上面看到的那樣，我四處亂竄，並嘗試從三個不同的角度來解決這個問題，但是卻一無所獲。 worked. 我覺得必須有一種方法可以使第一個工作正常，如果沒有其他方法，因為它工作。 但是我不明白。

我想我可以將其運行在四個單獨的列中，然后執行一個將這四個合並為一個過程。 但是即使那樣，我仍然不確定如何刪除將導致的重復（如上表所示，名稱可以出現在任何列中）。

只要我能以一列唯一名稱結尾並且不需要花費數小時來處理，我想我真的不介意我如何到達那里。

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"