Concatenate with ";" if values of 3 columns are same

[aravindhan_3]

Hi,

Need some vba or excel formula help to concatenate based on conditions.
please find below the as is data and result data , attached the file as well reference. first table is as data and 2nd table is result data.

I want to concatenate values of "Sub product code" ( colc c) if column A, B & Column D are same , example below



Thanks for the help
Regards
Arvind

[SamT]

IMO, that will require VBA Code. For VBA Code, we must see the complete top few rows of the original Table.

NB: All the Columns and the first 5 rows, including the Headers.


Can we assume that the Table will always be sorted by Country, then Sub Product Code, then Commission%?

Can we omit the Duplicate Rows? (Rows 6 and 10 in your example.) Omitting Duplicates will be much easier to code for.

[aravindhan_3]

Hi Sam,

Yes data will always be sorted by country , then Sub product code and then Commission
and yes, the result should be without duplicate rows

Thanks

[Paul_Hossler]

Something simple and straight forward

Option Explicit


Sub ConCatACD()
    Dim ws As Worksheet
    Dim r As Range
    Dim A() As String, B() As String, C() As String
    Dim i As Long, j As Long
    
    'init
    Set ws = Worksheets("Sheet1")
    Set r = ws.Cells(1, 1).CurrentRegion
    
    'make temp array
    ReDim A(1 To r.Rows.Count)
    ReDim B(1 To r.Rows.Count)
    ReDim C(1 To r.Rows.Count)
    
    'define matches and fill array with the match values
    With r
        For i = LBound(A) + 1 To UBound(A)
            A(i) = .Cells(i, 1).Value & "#" & .Cells(i, 2).Value & "#" & .Cells(i, 4).Value & "#"
            B(i) = .Cells(i, 3).Value
        Next i
    End With


    'look for more than one
    For i = LBound(A) To UBound(A)
        For j = LBound(A) To UBound(A)
            If A(i) = A(j) And i <> j Then
                If Len(C(i)) = 0 Then
                    C(i) = B(i) & ";" & B(j)
                Else
                    C(i) = C(i) & ";" & B(j)
                End If
            End If
        Next j
    Next i


    'make order of match the same
    For i = LBound(A) To UBound(A)
        For j = LBound(A) To UBound(A)
            If A(i) = A(j) Then C(j) = C(i)
        Next j
    Next i
    
    'pub back on worksheet
    For i = LBound(C) To UBound(C)
        If Len(C(i)) > 0 Then ws.Cells(i, 3).Value = C(i)
    Next i


    'remove dups
    r.RemoveDuplicates Columns:=Array(1, 2, 3, 4), Header:=xlYes


End Sub

[SamT]

Here's another version That works in a Standard Module

Option Explicit

Private Enum Array_and_Table_Column_Numbers
'Edit to include all columns. Edit "Concatting" code section below to suit
    Country = 1
    ProductCode = 2
    SubProductCode = 3
    Commisssion = 4
End Enum

Sub Concatenate_SubProduct_Codes()
'Declare Arrays
    Dim SrcArray, DestArray

'Array Row numbers
    Dim i As Long, j As Long, k As Long
    Dim LR As Long, ColumnCount As Long

'Sheet and Range Name Variables
    Dim Src As Range, Dest As Range

'Edit to suit
    LR = ThisWorkbook.Sheets("Sheet1").Cells(Rows.Count, "A")
    ColumnCount = 4
    Set Src = ThisWorkbook.Sheets("Sheet1").Range("A1")
    Set Dest = ThisWorkbook.Sheets("Sheet1").Range("F1")
    
    SrcArray = Src.CurrentRegion
    ReDim DestArray(1 To LR, 1 To ColumnCount)

'Concatting
    'Headers
    DestArray(1, Country) = SrcArray(1, Country)
    DestArray(1, ProductCode) = SrcArray(1, ProductCode)
    DestArray(1, SubProductCode) = SrcArray(1, SubProductCode)
    DestArray(1, Commisssion) = SrcArray(1, Commisssion)

k = 2 'First open row in DestArray
For i = 2 To LR
    j = i + 1 'Used to compare next Row's Values
    
    'First, record this row. Edit to include all columns
    DestArray(k, Country) = SrcArray(i, Country)
    DestArray(k, ProductCode) = SrcArray(i, ProductCode)
    DestArray(k, SubProductCode) = SrcArray(i, SubProductCode)
    DestArray(k, Commisssion) = SrcArray(i, Commisssion)

    If j < LR Then 'THere are still more rows
    
        'If Values are the same for two, or more, Rows, then
        Do While _
        SrcArray(i, Commision) = SrcArray(j, Commision) And _
        SrcArray(i, Country) = SrcArray(j, Country) And _
        SrcArray(i, SubProductCode) = SrcArray(j, SubProductCode)
        
            'Do the Concatenation
            DestArray(k, SubProductCode) = _
            DestArray(k, SubProductCode) & ";" & SrcArray(j, SubProductCode)
            j = j + 1 'Check the next Row
            If j > LR Then Exit For
        Loop
    End If
    k = k + 1 'Increment DestArray Row number
Next i 'Next SrcArray Row number

'Paste the new data. This will paste some empty rows below the data
    Dest.Resize(UBound(DestArray), ColumnCount) = DestArray.Value
End Sub

[aravindhan_3]

Thanks Paul,

This work, Need another help! Can we keep the original data as is but, get the output on a different sheet which is already there called "Output"?

Thanks

[SamT]

In my version: Change

Set Dest = ThisWorkbook.Sheets("Sheet1").Range("F1")

to

Set Dest = ThisWorkbook.Sheets("Output").Range("A1")

[Paul_Hossler]

This?

Option Explicit


Sub ConCatACD()
    Dim ws As Worksheet
    Dim r As Range
    Dim A() As String, B() As String, C() As String
    Dim n As Long, i As Long, j As Long
    Dim s As String, s1 As String
    
    'init
    Set ws = Worksheets("Output")
    
    Worksheets("Sheet1").Cells(1, 1).CurrentRegion.Copy ws.Cells(1, 1)
    Set r = ws.Cells(1, 1).CurrentRegion
    
    'make temp array
    ReDim A(1 To r.Rows.Count)
    ReDim B(1 To r.Rows.Count)
    ReDim C(1 To r.Rows.Count)
    
    'define matches and fill array with the match values
    With r
        For i = LBound(A) + 1 To UBound(A)
            A(i) = .Cells(i, 1).Value & "#" & .Cells(i, 2).Value & "#" & .Cells(i, 4).Value & "#"
            B(i) = .Cells(i, 3).Value
        Next i
    End With


    'look for more than one
    For i = LBound(A) To UBound(A)
        For j = LBound(A) To UBound(A)
            If A(i) = A(j) And i <> j Then
                If Len(C(i)) = 0 Then
                    C(i) = B(i) & ";" & B(j)
                Else
                    C(i) = C(i) & ";" & B(j)
                End If
            End If
        Next j
    Next i


    'make order of match the same
    For i = LBound(A) To UBound(A)
        For j = LBound(A) To UBound(A)
            If A(i) = A(j) Then C(j) = C(i)
        Next j
    Next i
    
    'pub back on worksheet
    For i = LBound(C) To UBound(C)
        If Len(C(i)) > 0 Then ws.Cells(i, 3).Value = C(i)
    Next i


    'remove dups
    r.RemoveDuplicates Columns:=Array(1, 2, 3, 4), Header:=xlYes
    r.EntireColumn.AutoFit


End Sub

[aravindhan_3]

Super Paul, it works.. Thanks a ton.
you can shoot me if you have to.

I had to split my question/requirement earlier to make sure I explain it well. This piece of code perfectly works. And there is an another logic to be added with this.
With the current logic, we have looked Column A "country", Column B "Product code" & Column D Commission% if all are same we have concatenated Column C "Sub product code".

In addition & with only diff is concatenate column B as well
We have to look at Column A "country", Column C "Product code" & Column D Commission% if all are same we have concatenated Column B "Product code".

It would be really great if one piece of code does both of these. I am ok if we have to run macro twice for 2 diff logic and try something manually to put together.

I had attached the sample file and output.

[Paul_Hossler]

Try this -- seems to work

Because of the Level check, I went to using the worksheet more than arrays

Also I think you wanted to join all 3 88186961 lines

Argentina	2	88186961	30.00%
Argentina	3	88186961	30.00%
Argentina	4	88186961	30.00%

Edit -- BTW, the title says semi-colons but your example users commas

Option Explicit


Sub MacroVer2()
    Dim ws As Worksheet
    Dim r As Range, r1 As Range
    Dim i As Long
    
    'init
    Set ws = Worksheets("Output")
    ws.Cells(1, 1).CurrentRegion.Clear
        
    Worksheets("Sheet1").Cells(1, 1).CurrentRegion.Copy ws.Cells(1, 1)
    Set r = ws.Cells(1, 1).CurrentRegion
    Set r1 = r.Cells(2, 1).Resize(r.Rows.Count - 1, r.Columns.Count)


    'sort by Country-Code-Commish = Cols ACD
    With ws.Sort
        .SortFields.Clear
        .SortFields.Add Key:=r1.Columns(1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SortFields.Add Key:=r1.Columns(3), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SortFields.Add Key:=r1.Columns(4), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SetRange r
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    With r
        For i = r.Rows.Count To 3 Step -1
            'same country and code and commish
            If (.Cells(i, 1).Value = .Cells(i - 1, 1).Value) And (.Cells(i, 2).Value = .Cells(i - 1, 2).Value) And (.Cells(i, 4).Value = .Cells(i - 1, 4).Value) Then
                If InStr(.Cells(i - 1, 3).Value, .Cells(i, 3).Value) = 0 Then
                    .Cells(i - 1, 3).Value = .Cells(i - 1, 3).Value & "," & .Cells(i, 3).Value
                    .Rows(i).Delete
                End If
            End If
        Next i
    End With
    
    Set r = ws.Cells(1, 1).CurrentRegion
    Set r1 = r.Cells(2, 1).Resize(r.Rows.Count - 1, r.Columns.Count)


    'sort by Country-level-Commish = Cols ABD
    With ws.Sort
        .SortFields.Clear
        .SortFields.Add Key:=r1.Columns(1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SortFields.Add Key:=r1.Columns(4), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SortFields.Add Key:=r1.Columns(2), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SetRange r
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    With r
        For i = r.Rows.Count To 3 Step -1
            'same country and level and commish
            If (.Cells(i, 1).Value = .Cells(i - 1, 1).Value) And (.Cells(i, 3).Value = .Cells(i - 1, 3).Value) And (.Cells(i, 4).Value = .Cells(i - 1, 4).Value) Then
                If InStr(.Cells(i - 1, 2).Value, .Cells(i, 2).Value) = 0 Then
                    .Cells(i - 1, 2).Value = .Cells(i - 1, 2).Value & "," & .Cells(i, 2).Value
                    .Rows(i).Delete
                End If
            End If
        Next i
    End With
    
    
    Set r = ws.Cells(1, 1).CurrentRegion
    Set r1 = r.Cells(2, 1).Resize(r.Rows.Count - 1, r.Columns.Count)


    'Final sort by Country-level-Code - Commish = Cols ABCD
    With ws.Sort
        .SortFields.Clear
        .SortFields.Add Key:=r1.Columns(1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SortFields.Add Key:=r1.Columns(2), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SortFields.Add Key:=r1.Columns(3), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SortFields.Add Key:=r1.Columns(4), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SetRange r
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    r.EntireColumn.AutoFit
    
    MsgBox "All Done"
End Sub

[aravindhan_3]

Thanks Paul, but somehow its not giving right result,

please refer the file with small data, for country UA Emirates, the levels 1,2,3 &4 same sub product code and same % but its creating multiple rows instead of 1 row.

you can run the macro and check the output tab,

thanks for the help in advance

Regards
Arvind

[SamT]

Are these two different Tables? One with a Product Code Column and one with a Level Column? And Sub Product Code.

Or is it one Table with both Product Code and Level Columns? And Sub Product Code.



BTW, I noticed a logic error in the code in my Post #5

k = 2 'First open row in DestArray
For i = 2 To LR
    j = i + 1 'Used to compare next Row's Values
    
    'First, record this row. Edit to include all columns
    DestArray(k, Country) = SrcArray(j, Country)
    DestArray(k, ProductCode) = SrcArray(j, ProductCode)
    DestArray(k, SubProductCode) = SrcArray(j, SubProductCode)
    DestArray(k, Commisssion) = SrcArray(j, Commisssion)

Should read

k = 2 'First open row in DestArray
For i = 2 To LR
    j = i + 1 'Used to compare next Row's Values
    
    'First, record this row. Edit to include all relevant columns
    DestArray(k, Country) = SrcArray(i, Country)
    DestArray(k, ProductCode) = SrcArray(i, ProductCode)
    DestArray(k, SubProductCode) = SrcArray(i, SubProductCode)
    DestArray(k, Commisssion) = SrcArray(i, Commisssion)

[Paul_Hossler]

try this version

Option Explicit


Const cCountry As Long = 1
Const cLevel As Long = 2
Const cCode As Long = 3
Const cCommish As Long = 4


Sub MacroVer3()
    Dim ws As Worksheet
    Dim r As Range, r1 As Range
    Dim i As Long
    Dim A As String, B As String, C As String, D As String
    Dim A1 As String, B1 As String, C1 As String, D1 As String
    
    'init
    Set ws = Worksheets("Output")
    ws.Cells(1, cCountry).CurrentRegion.Clear
        
    
    'make working coly and remove any dups
    Worksheets("Sheet1").Cells(1, cCountry).CurrentRegion.Copy ws.Cells(1, cCountry)
    
    ws.Cells(1, 1).CurrentRegion.RemoveDuplicates Columns:=Array(cCountry, cLevel, cCode, cCommish), Header:=xlYes


    
    'sort by Country-Level-Code-Commish
    Set r = ws.Cells(1, cCountry).CurrentRegion
    Set r1 = r.Cells(2, 1).Resize(r.Rows.Count - 1, r.Columns.Count)


    With ws.Sort
        .SortFields.Clear
        .SortFields.Add Key:=r1.Columns(cCountry), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SortFields.Add Key:=r1.Columns(cCode), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SortFields.Add Key:=r1.Columns(cLevel), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SortFields.Add Key:=r1.Columns(cCommish), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SetRange r
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    
    'pass #1 - merge products if same Level
    With r
        For i = r.Rows.Count To 3 Step -1
            'same country and code and commish
            If (.Cells(i, cCountry).Value <> .Cells(i - 1, cCountry).Value) Then GoTo NextLine
            If (.Cells(i, cCommish).Value <> .Cells(i - 1, cCommish).Value) Then GoTo NextLine
            If (.Cells(i, cLevel).Value <> .Cells(i - 1, cLevel).Value) Then GoTo NextLine
            
            .Cells(i - 1, cCode).Value = .Cells(i - 1, cCode).Value & ";" & .Cells(i, cCode).Value
            .Rows(i).Delete
NextLine:
        Next i
    End With
    
    
    'pass #2 - merge level if same product
    Set r = ws.Cells(1, cCountry).CurrentRegion
    Set r1 = r.Cells(2, 1).Resize(r.Rows.Count - 1, r.Columns.Count)
    
    With r
        For i = r.Rows.Count To 3 Step -1
        
            Debug.Print i
        
            'same country and code and commish
            If (.Cells(i, cCountry).Value <> .Cells(i - 1, cCountry).Value) Then GoTo NextLine2
            If (.Cells(i, cCommish).Value <> .Cells(i - 1, cCommish).Value) Then GoTo NextLine2
            If (.Cells(i, cCode).Value <> .Cells(i - 1, cCode).Value) Then GoTo NextLine2
            
            .Cells(i - 1, cLevel).Value = .Cells(i - 1, cLevel).Value & ";" & .Cells(i, cLevel).Value
            .Rows(i).Delete
NextLine2:
        Next i
    End With
    
    ws.Cells(1, cCountry).CurrentRegion.EntireColumn.AutoFit
    
    MsgBox "All Done"
End Sub

[parttime_guy]

Hi All

Solutions by SamT and Paul_Hossler are Great

Going through the post aravindhan_3 had requested for some FORMULA solution
In the attached file Sheet 2 has a FORMULA solution
Kindly review

[arnelgp]

can't believe that that people here always think of VBA as the last resort?

copy Sheet1 to New Sheet.
Erase all text from "Sub Product Code" on the New Sheet.
copy this formula on Cell C2 of New Sheet:

=IF(AND(Sheet1!B2=Sheet1!B1,Sheet1!D2=Sheet1!D1),Sheet1!C1&";"&Sheet1!C2,IF(AND(Sheet1!B2=Sheet1!B3,Sheet1!D2=Sheet1!D3),Sheet1!C2&";"&Sheet1!C3,Sheet1!C2))

https://www.dropbox.com/scl/fi/jy3py...ez52gdn2abvxhu

if you need to do it in PowerQuery:
https://exceloffthegrid.com/power-qu...a-single-cell/