Поиск значения и объединение соответствующего значения в одну ячейку (с прерывателем строки vbCrLf)

Question

У меня есть эта таблица с оборудованием и соответствующими свойствами:

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

Я уже пробовал использовать пользовательские функции, такие как:

Function CusVlookup(lookupval, lookuprange As Range, indexcol As Long)
 Dim x As Range
 Dim result As String
 result = ""
 For Each x In lookuprange
     If x = lookupval Then
         result = result & " " & x.Offset(0, indexcol - 1)
     End If
 Next x
 CusVlookup = result
End Function

CusVlookup отлично работает, но он слишком тяжелый, и у меня 2000+ уникальные значения оборудования, поэтому excel просто разбивает или занимает слишком много времени для вычисления Я также использовал формулу массива функций TEXTJOIN, тот же результат, очень медленное и превосходное дробление

Мне нужно объединить ячейки с помощью прерывателя строки (vbCrLf)Есть ли код VBA для достижения той же цели?

Спасибо!

Answer 1

Вы можете использовать VBA с объектом словаря, вы также можете использовать Power Query aka Get&Transform, который был доступен с Excel 2010

В 2016 году перейдите на вкладку «Данные» и выберите «Из таблицы / диапазона» (может отличаться в более ранних версиях).

Когда откроется PQ UI, выберите

• Группировка по: Оборудование
• Добавить пользовательский столбец, используя формулу: =Table.Column([Grouped],"Properties")
• Извлечение значений с использованием пользовательского разделителя (перевод строки)
• Закрыть и загрузить
• В первый раз вам нужно установить свойство Wrap Text, а также автоматически подогнать столбец. После этого вы можете обновить запрос при необходимости, и эти свойства сохранятся.

Результаты по вашим данным:

Или вы можете использовать VBA:

'Set Reference to Microsoft Scripting Runtime
'  or use late-binding to `Scripting.Dictionary`
Option Explicit
Sub Connect()
  Dim wsSrc As Worksheet, wsRes As Worksheet, rRes As Range
  Dim vSrc As Variant, vRes As Variant
  Dim D As Dictionary, COL As Collection, Key As Variant
  Dim I As Long, V As Variant
  Dim S As String

'Set source and results worksheets and ranges
Set wsSrc = Worksheets("Source")
Set wsRes = Worksheets("Results")
    Set rRes = wsRes.Cells(1, 1)

'read source data into VBA array for fastest processing
With wsSrc
    vSrc = .Range(.Cells(1, 1), .Cells(.Rows.Count, 2).End(xlUp))
End With

'Collect properties into dictionary item keyed to Equipment
Set D = New Dictionary
    D.CompareMode = TextCompare

For I = 2 To UBound(vSrc, 1)
    Key = vSrc(I, 1)
    If Not D.Exists(Key) Then
        Set COL = New Collection
        COL.Add Item:=vSrc(I, 2)
        D.Add Key:=Key, Item:=COL
    Else
        D(Key).Add vSrc(I, 2)
    End If
Next I

'Write new stuff into VBA results array
ReDim vRes(0 To D.Count, 1 To 2)

'Headers
vRes(0, 1) = "Equipment"
vRes(0, 2) = "Properties"

'Populate
I = 0
For Each Key In D.Keys
    I = I + 1
    S = ""
    vRes(I, 1) = Key
    For Each V In D(Key) 'iterate through the collection
        S = S & vbLf & V
    Next V
    vRes(I, 2) = Mid(S, 2) 'remove the leading LF
Next Key

'write results to worksheet and format
Application.ScreenUpdating = False
Set rRes = rRes.Resize(UBound(vRes, 1) + 1, UBound(vRes, 2))
With rRes
    .EntireColumn.Clear
    .Value = vRes
    .ColumnWidth = 255
    With .Rows(1)
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
    End With
    .Columns(2).WrapText = True
    .Columns(1).VerticalAlignment = xlCenter
    .EntireColumn.AutoFit
    .EntireRow.AutoFit
    .Style = "Output"
End With

End Sub

Answer 2

Попробуйте код ниже (вам нужно добавить ссылку на Microsoft Scripting Runtime в Инструменты> Ссылки ...):

Sub Test()
    ' in order to optimize macro
    Application.ScreenUpdating = False
    Application.EnableEvents = False

    Dim wsSource As Worksheet, wsTarget As Worksheet
    ' set source worksheet and target worksheet, where we will write data
    Set wsSource = Worksheets("Arkusz1")
    Set wsTarget = Worksheets("Arkusz2")

    Dim rangeArray As Variant, lastRow As Long
    lastRow = wsSource.Cells(wsSource.Rows.Count, 2).End(xlUp).Row
    ' read whole array to memory
    rangeArray = Range("A1:B" & lastRow).Value2

    Dim dict As Dictionary, i As Long
    Set dict = New Dictionary

    For i = LBound(rangeArray, 1) To UBound(rangeArray, 1)
        If dict.Exists(rangeArray(i, 1)) Then
            dict(rangeArray(i, 1)) = dict(rangeArray(i, 1)) & vbCrLf & rangeArray(i, 2)
        Else
            dict(rangeArray(i, 1)) = rangeArray(i, 2)
        End If
    Next

    For i = 0 To dict.Count - 1
        wsTarget.Cells(i + 1, 1) = dict.Keys(i)
        wsTarget.Cells(i + 1, 2) = dict(dict.Keys(i))
    Next

    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub