查找值并将相应的值连接到一个单元格中（使用换行符 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