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

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

Does the concatenation needs to be in increasing value order or the order the numbers are encountered? — QHarr, Feb 28 '18 at 14:22
The concatenation would be best to be smallest to largest Ie 123 before 456. This is not essential — George H, Feb 28 '18 at 14:25
Here are some example codes: https://stackoverflow.com/questions/28679758/concatenate-top-row-cells-if-column-below-has-1 they are horizontal, but similar. — Scott Craner, Feb 28 '18 at 14:36
https://stackoverflow.com/questions/44706211/excel2011-vlookup-and-combine This is vertical. — Scott Craner, Feb 28 '18 at 14:37
basically go through the `TextJoin` tag and you will find many examples of code. — Scott Craner, Feb 28 '18 at 14:38

QHarr · Accepted Answer · 2018-03-01T06:09:54.867

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

edited Mar 01 '18 at 06:09

answered Feb 28 '18 at 15:01

QHarr

83,427
12
54
101

Hi, I have updated my data samples. How does your code then change to reflect these, do you mind please advising? The samples will not change again. – George H Feb 28 '18 at 15:23
You haven't made a decision on the last answer I gave yet.... https://stackoverflow.com/questions/49027250/finding-the-missing-values-based-on-criteria-in-column-c . That code is doing pretty much the same thing as you are now asking. – QHarr Feb 28 '18 at 15:36
Hi, Thanks, I have accepted the answer that I used now on this question. Would it be possible to change the above code to reflect the new expected data please? – George H Feb 28 '18 at 15:44
Hi, sorry I am new to Stack overflow so not sure how to do these type of things. I have accepted your answer. – George H Feb 28 '18 at 16:00
Just wondering how to change the cell values now so I can try this one – George H Feb 28 '18 at 16:08
The solution to this would be based on the code I gave in [this](https://stackoverflow.com/questions/49027250/finding-the-missing-values-based-on-criteria-in-column-c) version which takes two far apart column and then output one filled column. Worth trying to understand what it is doing. It is the same principle as you need now. – QHarr Feb 28 '18 at 16:10
Would it be possible to add comments in the code please? – George H Feb 28 '18 at 16:12
I am finding it a little bit hard to edit at the moment as I am wondering why the transactions sheet would not have been used first. – George H Feb 28 '18 at 16:24
The transactions sheet is what you wish to update. So it is your target. The roots sheet is where you are actually getting the values from. – QHarr Feb 28 '18 at 16:41
In Roots what you want to do is loop all the IDs and if the ID is the same you want to add the associated number to your concatenation string. After you have these strings, you want to deposit said strings, against the appropriate ID in the transactions sheet. I use the ID as a key to the dictionary to retrieve the value which is the concatenated string. There is the placeholder string "?" also for missing values for an ID. – QHarr Feb 28 '18 at 16:49
Hi, I have added the code in the problem description that I am using. It does not work as the subscript is out of range so one of numbers I have put must be incorrect. – George H Feb 28 '18 at 16:53
I keep saying, perhaps the hyperlink wasn't clear, structure your answer, potentially on my answer here https://stackoverflow.com/questions/49027250/finding-the-missing-values-based-on-criteria-in-column-c This is the answer which matches your problem statement in terms of having 2 disparate columns and needing to fill one column with return values. – QHarr Feb 28 '18 at 16:58
Hi, sorry for the delay, this works for my proof of concept thankyou – George H Mar 05 '18 at 09:33

DisplayName · Answer 2 · 2018-02-28T17:38:19.247

0

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

edited Feb 28 '18 at 17:38

answered Feb 28 '18 at 15:14

DisplayName

13,283
2
11
19

Hi, I have amended my expected result, how would your code then change to reflect this please? – George H Feb 28 '18 at 17:21
@GeorgeH, well that you should infer from my previous code explanations. anyhow see edited code. if this solves your question then please mark it as accepted. thank you – DisplayName Feb 28 '18 at 17:40
Hi, unfortunately this does not provide any result in column A when this is ran. Can you please advise? – George H Mar 01 '18 at 10:01
where did you ever say results were to be written in column A? actually the code processes sheet "transactions" column C cells, gets corresponding column A value, searches sheet "Roots" column "C" for all cells with that value, concatenates their column D corresponding values into a string and writes it to sheet "transactions" column AA. – DisplayName Mar 01 '18 at 10:38
sorry, I meant AA is where the results are to be put. This is currently not happening. – George H Mar 01 '18 at 10:43
does the description of my last comment match exactly the expected behavior? if not, then please detail the exact expected behavior. – DisplayName Mar 01 '18 at 10:47

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

2 Answers2