☰

Excel — поиск уникальных значений в одном столбце и соответствующих значений в другом

tag-icon • tag-icon microsoft-excel worksheet-function vba sorting
Excel — поиск уникальных значений в одном столбце и соответствующих значений в другом

У меня есть экспорт базы данных компонентов и меток в двух столбцах. Столбец A содержит компонент, а столбец B содержит метки, связанные с компонентом. Один и тот же компонент может отображаться несколько раз в столбце A, но с разным набором меток.

Мне нужно создать уникальный список компонентов в ячейке D и перечислить все связанные метки в ячейке рядом с компонентом в столбце E.

Я знаю, как создать уникальный список значений в столбце A, но не знаю, как разделить значения, если в одной ячейке их несколько. Я не могу изменить способ экспорта этих данных базой данных.

Я достаточно хорошо знаю VBA, чтобы создать макрос для этого, если это единственный способ сделать это. Любая помощь будет оценена.

Вот что мне нужно сделать:

Вот что мне нужно сделать

решение1

Вы можете сделать это, создав двумерный словарь. Я предложил словарь, потому что он заботится об уникальности. Я написал макрос, который выполняет эту задачу (по крайней мере, для данных вашего примера). Сначала он настраивает двумерную структуру данных, а затем выводит ее в алфавитном порядке. Он включает упрощенную версию функции сортировки, которую я нашел здесь:https://exceloffthegrid.com/sorting-an-array-alphabetically-with-vba/

В моем макросе данные считываются со строки 1 ( For i = 1 To Cells(Row.Count...) до последней строки, содержащей данные. При необходимости отрегулируйте. Вы также могли установить правильные буквы столбцов (просто найдите ActiveSheet.Range, и вы увидите).

Обратите внимание, что функция сортировки сортирует по алфавиту, поэтому метка 11 будет перед меткой 2. Если это важно, я думаю, что самый быстрый способ — создать вторую функцию сортировки для массива меток, которая преобразует метки в числа перед сравнением. Я знаю, я знаю, что это приводит к ужасной производительности, но, надеюсь, это не имеет значения :)

Сначала макрос считывает все входные строки и разбивает их по символам (удаляя пробелы перед ними — если компоненты и метки всегда разделяются запятой и пробелом, можно упростить). Для каждого компонента он создает подсловарь, где хранятся метки, и заполняет их. Если компонент встречается несколько раз, существующий словарь обновляется. Это первый основной цикл For. Если данные настроены, он выводит данные, отсортированные по столбцам D и E. Это второй основной цикл For Each.

Наконец, код (он у меня в разделе рабочей книги, а не в модуле кода листа, но мог бы работать и там):

Sub CollectLabels()
    Dim spl() As String
    Dim dict
    Dim subDict
    Dim lbl As String

    ' Collect data into a 2-dimensional dictionary
    Set dict = CreateObject("Scripting.Dictionary")
    For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
        comps = Split(Replace(ActiveSheet.Range("A" & i).Text, " ", ""), ",")
        For Each comp In comps
            If Not dict.Exists(comp) Then
                Set subDict = CreateObject("Scripting.Dictionary")
                dict.Add comp, subDict
            End If
            Labels = Split(Replace(ActiveSheet.Range("B" & i).Text, " ", ""), ",")
            For Each Label In Labels
                dict(comp)(Label) = 1
            Next Label
        Next comp
    Next i

    i = 1
    ' Output the dictionary contents
    For Each Key In SortArray(dict.Keys)
        ActiveSheet.Range("D" & i).Value = Key
        lbl = ""
        For Each Key2 In SortArray(dict(Key).Keys)
            lbl = lbl & Key2 & ", "
        Next Key2
        ActiveSheet.Range("E" & i).Value = lbl
        i = i + 1
    Next Key
End Sub

Function SortArray(arr As Variant)

Dim i As Long
Dim j As Long
Dim Temp

For i = LBound(arr) To UBound(arr) - 1
    For j = i + 1 To UBound(arr)
        If arr(i) > arr(j) Then
            Temp = arr(j)
            arr(j) = arr(i)
            arr(i) = Temp
        End If
    Next j
Next i

SortArray = arr

End Function

Связанный контент