excel - 查找值并将相应的值连接到一个单元格中(使用换行符 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 与字典对象一起使用，也可以使用 Power Query又名 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