How to concatenate range of cells according to criteria

Question

I have 2 columns in excel as below:

CutNo    Data       
1        A          
1        B
1        C

2        A          
2        B

3        A

I want to concatenate data of column data if the Cut No is the same and put it in another Column Named Concatenate and Count the number of occurrences and put it in another column as below

CutNo    Data       Concatenate     Occurrences
1        A          A & B & C           1 
1        B
1        C

2        A          A & B               1
2        B

3        A          A                   1

I use the following code

    Sub Unique()
    Dim Rng, Cel As Range
    Dim lr As Long
    Dim x As Integer
    Dim str As String
    lr = Sheets("Report").Cells(Rows.count, 1).End(xlUp).Row
    Set Rng = Sheets("Report").Range("A2:A" & lr)
    For x = 1 To Rng.count
    For Each Cel In Rng.Cells
    If Cel.Value = x Then
    str = str & Rng.Cells(x, 1).Offset(0, 7) & ","
    End If
    Next Cel
    Rng.Cells(x, 1).Offset(0, 10).Value = str
    Next x
    End Sub

I did not get the proper result I need,

Appreciate your support

Thanks, Regards

Moheb Labib

user_2872922 · Answer

If you have Excel O365 with the FILTER function, you don't need VBA:

(Note: I have asssumed that Occurrences can be calculated by just counting the number of rows of CutNo. If you mean something else, please clarify)

C2: =IF(AND(A2<>A1,A2<>""),TEXTJOIN(" & ",TRUE,FILTER($B:$B,$A:$A=A2)),"")
D2: =IF(AND(A2<>A1,A2<>""),COUNTIF($A:$A,A2),"")

and fill down.

You can also do this using Power Query available in Excel 2010+

Select the entire range to include
- *cannot auto-select since there are blank rows
In Excel 2016+ : Data --> Get & Transform --> From Table/Range
- I'm not sure about the earlier versions, where you would download a free MS add-in for this functionality.
When the PQ Editor opens, select Home --> Advanced Editor and paste the M Code below into the window that opens.
- Change the Table name in Line 2 to be the name of the Table generated when you opened PQ.

For explanations, examine the items in the Applied Steps window. If you float your cursor over any of the i icons, you will see the comment associated; if you double click on a gear wheel, it will open a dialog window so you can examine what was done.

Close and Load to: I select the column next to the original data, but there are other ways to do this.

M Code

let
    Source = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],
    #"Changed Type" = Table.TransformColumnTypes(Source,{{"CutNo", Int64.Type}, {"Data", type text}}),

    //make the grouping easier, else we'd have a group with the blank rows
    #"Removed Blank Rows" = Table.SelectRows(#"Changed Type", each not List.IsEmpty(List.RemoveMatchingItems(Record.FieldValues(_), {"", null}))),
    
    //Group by CutNo -- hence no need to sort
    #"Grouped Rows" = Table.Group(#"Removed Blank Rows", {"CutNo"}, {{"Grouped", each _, type table [CutNo=nullable number, Data=nullable text]}}),

    //add a blank row at the bottom of each grouped table (each CutNo group)
    #"Added Custom" = Table.AddColumn(#"Grouped Rows", "addBlankRow", each Table.InsertRows([Grouped],
            Table.RowCount([Grouped]),
            {[CutNo=null, Data=null]})),

    //remove unneded columns
    #"Removed Columns" = Table.RemoveColumns(#"Added Custom",{"CutNo", "Grouped"}),
    #"Added Custom1" = Table.AddColumn(#"Removed Columns", "Custom", each Table.Column([addBlankRow],"Data")),

    //Concatenate the "Data"
    #"Extracted Values" = Table.TransformColumns(#"Added Custom1", {"Custom", each Text.Combine(List.Transform(_, Text.From), " & "), type text}),

    //Count the rows (subtract one since last row will be blank
    #"Added Custom2" = Table.AddColumn(#"Extracted Values", "Custom.1", each Table.RowCount([addBlankRow])-1),

    //Expand the Table column to put a blank row between each group of CutNo
    #"Expanded addBlankRow" = Table.ExpandTableColumn(#"Added Custom2", "addBlankRow", {"CutNo"}, {"addBlankRow.CutNo"}),

    //Add Index column so we can null out where there should be empty cells in the Concatenate Column
    #"Added Index" = Table.AddIndexColumn(#"Expanded addBlankRow", "Index", 0, 1, Int64.Type),
    #"Added Custom3" = Table.AddColumn(#"Added Index", "Concatenate", each 
        if [Index] = 0 
            then [Custom]
            else if [addBlankRow.CutNo] = null 
            then null 
            else if [addBlankRow.CutNo] = #"Expanded addBlankRow"[addBlankRow.CutNo]{[Index]-1} 
            then null 
            else [Custom]),

    //Blank cells in the Occurrence column if blank in the CutNo column
    #"Added Custom4" = Table.AddColumn(#"Added Custom3", "Occurrences", each 
        if [Concatenate] = null then null 
        else [Custom.1]),

    //Remove unneeded columns        
    #"Removed Columns1" = Table.RemoveColumns(#"Added Custom4",{"addBlankRow.CutNo", "Custom", "Custom.1", "Index"}),

    //Remove bottom row which will be blank
    #"Removed Bottom Rows" = Table.RemoveLastN(#"Removed Columns1",1)
in
    #"Removed Bottom Rows"

user_2233308 · Answer

Try the next code, please. Since you did not answer my clarification question, the code works with the assumption that occurrences means counting of each concatenated item:

Sub testConcatenateOnCriteria()
  Dim sh As Worksheet, lastRow As Long, dict As New Scripting.Dictionary
  Dim i As Long, count As Long, strVal As String, arr As Variant
  
  Set sh = ActiveSheet 'use here your sheet
  lastRow = sh.Range("A" & Rows.count).End(xlUp).Row

  For i = 2 To lastRow
    strVal = sh.Range("A" & i).Value
    If sh.Range("B" & i).Value <> "" Then
        If Not dict.Exists(strVal) Then
            dict.Add strVal, Array(sh.Range("B" & i).Value, 1, i)
        Else
            dict(strVal) = Array(dict(strVal)(0) & sh.Range("B" & i).Value, dict(strVal)(1) + 1, dict(strVal)(2))
        End If
    End If
  Next i
  ReDim arr(1 To lastRow, 1 To 2)
  arr(1, 1) = "Concatenate": arr(1, 2) = "Occurrences"
  For i = 0 To dict.count - 1
    arr(dict(dict.Keys(i))(2), 1) = dict(dict.Keys(i))(0): arr(dict(dict.Keys(i))(2), 2) = dict(dict.Keys(i))(1)
  Next i

  sh.Range("C1").Resize(UBound(arr), 2).Value = arr
End Sub

user_4361999 · Answer

First, your data in VBA form:

Cells.Clear
Cells(2, 1) = "1"
Cells(2, 2) = "A"
Cells(3, 1) = "1"
Cells(3, 2) = "B"
Cells(4, 1) = "1"
Cells(4, 2) = "C"
Cells(6, 1) = "2"
Cells(6, 2) = "A"
Cells(7, 1) = "2"
Cells(7, 2) = "B"
Cells(9, 1) = "3"
Cells(9, 2) = "A"

Second, your code reworked:

Dim rng As Range, Cel As Range
Dim lr As Long
Dim x As Integer, y As Integer
Dim str As String
lr = Cells(Rows.Count, 1).End(xlUp).Row
Set rng = Range("A2:A" & lr)
For x = 1 To rng.Count
str = ""
y = 0
For Each Cel In rng
If Cel.Value = x Then
str = str & rng.Cells(Cel.Row - 1, 2) & ","
If y = 0 Then y = Cel.Row - 1
End If
Next Cel
If y>0 Then rng.Cells(y, 4) = Left(str, Len(str) - 1)
Next x

Output:

Notes:

I have left 'occurrences' out as it seems vague.

Dim rng, Cel As Range should be Dim rng As Range, Cel As Range, otherwise rng is a declared as a Variant.

Other than that, I have just trimmed bits off, and added a routine to calculate and format the data properly.

Previously, you were using Rng.Cells(x, 1), but the value of x doesn't change throughout the Cel loop, so you need to access the Cel.Row property to find out where the row in question is.

The y variable stores the first occurrence of x for display purposes.

How to concatenate range of cells according to criteria

3 Answers