I have this table with equipments and corresponding properties:
I want to lookup value of equipment in this table and concatenate corresponding property values into one cells so that outcome would like this:
I’ve already tried using user defined functions like this:
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 works great but it’s too heavy and I have 2000+ unique values of equipment so excel just crushes or takes too long too calculate
I also used TEXTJOIN function array formula, same result, very slow and excel crushing
I need to join cells using line breaker (
Is there VBA code to accomplish the same goal?
You can use VBA with a dictionary object, you can also use
Power Query aka
Get&Transform which has been available since Excel 2010
In 2016, navigate to the Data tab and Get From Table/Range (may be different in earlier versions).
When the PQ UI opens, select
- Group By: Equipment
- Add a custom column using formula:
- Extract values using a custom delimiter (linefeed)
- Close and Load
- The first time, you’ll need to set the
Wrap Textproperty and also auto fit the column. After that, you can update the query when needed and those properties will maintain.
Results using your data:
Or you can use 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
Try code below (you need to add reference to Microsoft Scripting Runtime in Tools > References…):
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