Как извлечь уникальные значения из нескольких столбцов и использовать их для заполнения одного столбца?

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   |
+--------+

Я хочу иметь возможность идентифицировать все уникальные записи из этих шести столбцов, а затем разместить их на другом листе. Моей первой мыслью было сделать это с помощью формул, и это сработало (я использовал INDEX MATCH с COUNTIF в разделе MATCH), но в таблице есть 11000 записей и 1200 различных имен, которые могут быть потенциально задействованы, и это заняло большинство дня для обработки. Я надеялся, что использование VBA ускорит его работу.

Я посмотрел на ряд возможных ответов. Во-первых, я пошел сюда: заполнил уникальные значения в массив VBA из 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 в таблице выше - Data - это лист, на котором хранятся данные, Crew - это лист, на котором я хочу, чтобы уникальные значения помещались). Но я не мог понять, как заставить его принимать значения из нескольких столбцов (от BE до BJ).

Затем я попробовал это, основываясь на ответе Джереми Томпсона в " Быстрее", чтобы получить все уникальные значения столбца в VBA?:

Sheets("Data").Select

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

Но, опять же, я не мог заставить ее поместить информацию из нескольких столбцов в один. В третьей попытке я посмотрел ответ студента Гэри из раздела Как извлечь уникальные значения из двух столбцов Excel VBA и попробовал это:

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://stackru.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

Предполагая, что у вас Excel 2016 и выше, вы можете сделать это с помощью Power Query. Преобразуйте диапазон данных в таблицу, выберите ячейку в таблице, выберите "Из таблицы" в разделе "Данные"> "Получить и преобразовать", а затем вставьте следующий код в расширенный редактор редактора Power Query (изменив 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"

Answer 4

Вот подход с использованием словаря. Просто укажите диапазон, который вы хотите найти, и 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