逗号根据匹配条件在新创建的列中定义值

Question

我在交易表上的A列中有一个值，其中包含交易的标识符。

为了能够找到此交易的客户信息，我在另一张名为“交易信息”的表格中查找。此处在列F中有一个值，它与事务表上的列A中的值匹配。虽然在交易信息表中列出了所有参与此交易的客户以及每个客户的唯一标识符。

在交易表上我创建了一个新列，我希望以逗号分隔格式显示与特定交易相关联的ID列表，如果可能的话，那么空格也会很好。

交易数据：

A栏：ID栏：AA：BID多个1？ 2？ 3？ 4？

根数据：

C列：ID栏：D：BID 1 100 1 200 1 300 2 101

基于示例的事务表中的预期结果。

Column A ID    Column AA: BID Multiple
1                 100,200,300
2                  101
3                    ?
4                    ?

 Sub test()

 Dim wb As Workbook
 Set wb = ThisWorkbook
 Dim ws As Worksheet
 Dim lastRow As Long
 Set ws = ThisWorkbook.Worksheets("Roots")
 lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

 Dim valuesArr()
 valuesArr = ws.Range("F2:G" & lastRow)       ' 1 TO 4, 1 TO 2

 Dim dict As Object
 Set dict = CreateObject("Scripting.Dictionary")
 Dim valuesString As String
 Dim currValue As Long
 Dim currRotation As Long
 Dim index As String

 For currRotation = LBound(valuesArr, 1) To UBound(valuesArr, 1)
    index = valuesArr(currRotation, 1)
    currValue = CStr(valuesArr(currRotation, 2))
    If Not dict.Exists(index) Then
        dict.Add index, currValue
    Else
        dict(index) = dict(index) & ";" & currValue
    End If
 Next currRotation

 Dim wsTarget As Worksheet
 Dim lastRowTarget As Long
 Set wsTarget = ThisWorkbook.Worksheets("transactions")
 lastRow = wsTarget.Cells(ws.Rows.Count, "A").End(xlUp).Row

 Dim valuesArr2()
 valuesArr2 = wsTarget.Range("A2:AA" & lastRow)

 Dim testValue As String

 For currRotation = LBound(valuesArr2, 1) To UBound(valuesArr2, 1)

  testValue = dict(CStr(valuesArr2(currRotation, 1)))

  If testValue = vbNullString Then testValue = "?"

  valuesArr2(currRotation, 27) = testValue

 Next currRotation
 wsTarget.Range("A2").Resize(UBound(valuesArr2, 1), UBound(valuesArr2, 
 27)) = valuesArr2

 End Sub

Answer 1

这对于原始帖子来说是无序的。假设数据从第2行开始，并具有如下所示的布局。

列D是输出连接字符串的位置。

*请注意，对原始问题的重复编辑可能意味着代码将不再符合规定的要求。

Option Explicit

Sub test()

    Dim wb As Workbook
    Set wb = ThisWorkbook
    Dim ws As Worksheet
    Dim lastRow As Long
    Set ws = ThisWorkbook.Worksheets("Roots")
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

    Dim valuesArr()
    valuesArr = ws.Range("A2:B" & lastRow)       ' 1 TO 4, 1 TO 2

    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")
    Dim currValue As Long
    Dim currRotation As Long
    Dim index As String

    For currRotation = LBound(valuesArr, 1) To UBound(valuesArr, 1)

        index = valuesArr(currRotation, 1)
        currValue = CStr(valuesArr(currRotation, 2))

        If Not dict.exists(index) Then

            dict.Add index, currValue

        Else

            dict(index) = dict(index) & ";" & currValue

        End If


    Next currRotation

    Dim wsTarget As Worksheet
    Dim lastRowTarget As Long
    Set wsTarget = ThisWorkbook.Worksheets("transactions")
    lastRow = wsTarget.Cells(ws.Rows.Count, "A").End(xlUp).Row

    Dim valuesArr2()
    valuesArr2 = wsTarget.Range("A2:D" & lastRow)

    Dim testValue As String

    For currRotation = LBound(valuesArr2, 1) To UBound(valuesArr2, 1)

      testValue = dict(CStr(valuesArr2(currRotation, 1)))

      If testValue = vbNullString Then testValue = "?"

      valuesArr2(currRotation, 4) = testValue

    Next currRotation

    wsTarget.Range("A2").Resize(UBound(valuesArr2, 1), UBound(valuesArr2, 2)) = valuesArr2

End Sub

Answer 2

根据OP修改的输入和输出列编辑

根据您的示例，ID在Roots表中是连续的，因此您可以如下所示

Sub main()
    Dim cell As Range

    With Worksheets("transactions") 'reference "transaction" sheet
        For Each cell In .Range("A2", .Cells(.Rows.Count, "A").End(xlUp)) 'loop through referenced sheet column A cells from row 2 down to last not empty one
            cell.Offset(, 26).value = GetIDDeals(cell.value) 'write in current cell offset 26 columns (i.e. column AA) the value of the BID
        Next
    End With

End Sub

Function GetIDDeals(ID As Variant) As String
    With Worksheets("Roots")
        With .Range("C1", .Cells(.Rows.Count, "C").End(xlUp)) 'reference its column C cells from row 1 (header) down to last not empty one
            .AutoFilter Field:=1, Criteria1:=ID ' filter referenced cells on 1st column with passed ID content
            Select Case Application.WorksheetFunction.Subtotal(103, .Columns(1)) 'let's see how many filtered cells
                Case Is > 2 'if more than 2, then we have more than 1 filtered value, since header gets always filtered
                    GetIDDeals = Join(Application.Transpose(.Offset(1, 1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).value), ",")
                Case 2 'if two filtered cells, then we have 1 filtered value, since header gets always filtered
                    GetIDDeals = .Offset(1, 1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).value
            End Select
        End With
        .AutoFilterMode = False
    End With
End Function