Home » excel » excel – Lookup value and concatenate corresponding value into one cells (with linebreaker vbCrLf)

excel – Lookup value and concatenate corresponding value into one cells (with linebreaker vbCrLf)

Posted by: admin May 14, 2020 Leave a comment

Questions:

I have this table with equipments and corresponding properties:

Table 1

I want to lookup value of equipment in this table and concatenate corresponding property values into one cells so that outcome would like this:

Table 2

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 (vbCrLf)
Is there VBA code to accomplish the same goal?

Thanks!

How to&Answers:

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: =Table.Column([Grouped],"Properties")
  • Extract values using a custom delimiter (linefeed)
  • Close and Load
  • The first time, you’ll need to set the Wrap Text property and also auto fit the column. After that, you can update the query when needed and those properties will maintain.

Results using your data:

enter image description here

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

Answer:

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