Comma Delimitting values in a new created column based on a matching condition - vba

Question

I have a value in column A on the transactions sheet which contains an Identifier for a Deal.
To be able to find out the customer information for this Deal I look in another sheet called Deal Information. Here there is a value in Column F which matches a value in Column A on the transactions sheet. Although on the Deal Information sheet it lists all the customers who are part of this deal as well as a unique identifier for each of the customers.
On the transactions sheet I have created a new column where by I want to display the list of ID's associated to a particular deal in comma delimited format if possible if not then a space will be good too.
transactions data:
Column A:ID Column: AA: BID Multiple
1 ?
2 ?
3 ?
4 ?
Roots data:
Column C: ID Column: D: BID
1 100
1 200
1 300
2 101
Expected Result in transaction table based on example.
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

This does an unordered, for the original posting . Assumes data starts in row 2 and has layout as shown below.
Column D being where the concatenated string is output.
*Please note repeated edits to the original question may mean code will no longer fit the stated requirements.
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

Edited as per OP's amended input and output columns
as per your examples, IDs are consecutive in Roots sheet
so you may go as follows
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