查找值并将相应的值连接到一个单元格中（使用换行符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函数数组公式，同样的结果，非常慢和excel破碎

我需要使用断路器连接单元（vbCrLf）是否有VBA代码来实现相同的目标？

谢谢！

Answer 1

您可以将VBA与字典对象一起使用，也可以使用自Excel 2010以来可用的Power Query aka Get&Transform

在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