VBA Arrays for concatenate?

[twelin]

Hi all,
I have long a list of entities with a unique code, and the countries where they are represented.
I want to discard all "GB" and then list all counties per entity in one row. See example.

I tried out with arrays but couldn't figure it out.

[TABLE="width: 0"]
[TR]
[TD]INPUT
[/TD]
[TD][/TD]
[TD][/TD]
[TD]Desired Output
[/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]ISIN
[/TD]
[TD]Country
[/TD]
[TD][/TD]
[TD]ISIN
[/TD]
[TD]Countries
[/TD]
[/TR]
[TR]
[TD]SE0000900169
[/TD]
[TD]GB
[/TD]
[TD][/TD]
[TD]SE0000900169
[/TD]
[TD]SE
[/TD]
[/TR]
[TR]
[TD]SE0000900169
[/TD]
[TD]SE
[/TD]
[TD][/TD]
[TD]SE0008103071
[/TD]
[TD]NO, SE
[/TD]
[/TR]
[TR]
[TD]SE0008103071
[/TD]
[TD]GB
[/TD]
[TD][/TD]
[TD]SE0011338441
[/TD]
[TD]FI, LU, SE
[/TD]
[/TR]
[TR]
[TD]SE0008103071
[/TD]
[TD]NO
[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]SE0008103071
[/TD]
[TD]NO
[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]SE0008103071
[/TD]
[TD]SE
[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]SE0011338441
[/TD]
[TD]FI
[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]SE0011338441
[/TD]
[TD]FI
[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]SE0011338441
[/TD]
[TD]GB
[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]SE0011338441
[/TD]
[TD]LU
[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]SE0011338441
[/TD]
[TD]SE
[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[/TABLE]

Does anyone have a good idea on how to perform this?

Regards
Tobias

 

[Fluff]

How about

Sub twelin()
   Dim Cl As Range
   
   With CreateObject("scripting.dictionary")
      For Each Cl In Range("B2", Range("B" & Rows.Count).End(xlUp))
         If Cl.Value <> "GB" Then
            If Not .Exists(Cl.Offset(, -1).Value) Then
               .Add Cl.Offset(, -1).Value, Cl.Value
            Else
               .Item(Cl.Offset(, -1).Value) = .Item(Cl.Offset(, -1).Value) & ", " & Cl.Value
            End If
         End If
      Next Cl
      Range("D2").Resize(.Count, 2).Value = Application.Transpose(Array(.Keys, .Items))
   End With
End Sub

 

[CalcSux78]

If you do not want duplicate countries, modify the Else statement in Fluff's code to this:

ElseIf InStr(1, .Item(Cl.Offset(, -1).Value), Cl.Value, vbTextCompare) = 0 Then
     .Item(Cl.Offset(, -1).Value) = .Item(Cl.Offset(, -1).Value) & ", " & Cl.Value
End If

 

[twelin]

Thank you Fluff for such a speedy help! Fantastic!

Your code works like a charm, however CalcSux78's was right about the duplicates. When I followed his suggestion I get an error code:

Sub twelin()
Dim Cl As Range

With CreateObject("scripting.dictionary")
For Each Cl In Range("B2", Range("B" & Rows.Count).End(xlUp))
If Cl.Value <> "GB" Then
If Not .Exists(Cl.Offset(, -1).Value) Then
.Add Cl.Offset(, -1).Value, Cl.Value
ElseIf InStr(1, .Item(C1.Offset(, -1).Value), C1.Value, vbTextCompare) = 0 Then
.Item(C1.Offset(, -1).Value) = .Item(C1.Offset(, -1).Value) & ", " & C1.Value
End If
Next Cl 'Compile error: Next without For
Range("D2").Resize(.Count, 2).Value = Application.Transpose(Array(.Keys, .Items))
End With
End Sub

How can that be? There is obviously a "For Each..." 7 rows up?

 

[Fluff]

You're missing an End If, before the Next Cl

 

[twelin]

Many thanks! Problem solved.

 

[Fluff]

Glad we could help & thanks for the feedback