Question

我有这张桌子，上面有设备和相应的属性：

Table 1

我想在此表中查找设备的值并将相应的属性值连接到一个单元格中，以便结果如下：

Table 2

我已经尝试使用用户定义的函数，如下所示：

this.state.currentPosition = cP;
document.body.style.setProperty('--item-left', - cP*this.state.unitWidth + "px");

CusVlookup的效果很好，但是它太重了，我拥有2000多种独特的设备值，因此excel只能压碎或花费太长时间进行计算我还使用了TEXTJOIN函数数组公式，结果相同，非常慢，并且表现出色

我需要使用换行器（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）加入单元是否有实现相同目标的VBA代码？

谢谢！

Answer 1

尝试以下代码（您需要在工具>参考中添加对Microsoft脚本运行时的引用）：

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

Answer 2

您可以将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

查找值并将相应值连接到一个单元格中（使用换行器vbCrLf）

2 个答案: