Macro to work with duplicate values in rows.

[mkrlhd]

I need your help to build a Macro that do this...

The problem:

[TABLE="class: grid, width: 500, align: left"]
<tbody>[TR]
[TD="align: center"]A[/TD]
[TD="align: center"]B[/TD]
[/TR]
[TR]
[TD="align: center"]702[/TD]
[TD="align: center"]12345[/TD]
[/TR]
[TR]
[TD="align: center"]702[/TD]
[TD="align: center"][/TD]
[/TR]
[TR]
[TD="align: center"]VSA[/TD]
[TD="align: center"][/TD]
[/TR]
[TR]
[TD="align: center"]702[/TD]
[TD="align: center"][/TD]
[/TR]
[TR]
[TD="align: center"]6A[/TD]
[TD="align: center"]12346[/TD]
[/TR]
[TR]
[TD="align: center"]CKM[/TD]
[TD="align: center"][/TD]
[/TR]
[TR]
[TD="align: center"]CKM[/TD]
[TD="align: center"][/TD]
[/TR]
[TR]
[TD="align: center"]701[/TD]
[TD="align: center"]12378[/TD]
[/TR]
[TR]
[TD="align: center"]701[/TD]
[TD="align: center"][/TD]
[/TR]
</tbody>[/TABLE]

​

The solution:

[TABLE="class: grid, width: 500, align: left"]
<tbody>[TR]
[TD="align: center"]A[/TD]
[TD="align: center"]B[/TD]
[/TR]
[TR]
[TD="align: center"]702,VSA[/TD]
[TD="align: center"]12345[/TD]
[/TR]
[TR]
[TD="align: center"]6A, CKM[/TD]
[TD="align: center"]12346[/TD]
[/TR]
[TR]
[TD="align: center"]701[/TD]
[TD="align: center"]12378[/TD]
[/TR]
</tbody>[/TABLE]

​

 

[Fluff]

How about

Sub ConcatUnique()
   Dim Rng As Range
   Dim Dic As Object
   Dim Cl As Range
   
   Set Dic = CreateObject("scripting.dictionary")
   For Each Rng In Range("B:B").SpecialCells(xlBlanks).Areas
      For Each Cl In Rng.Offset(-1, -1).Resize(Rng.Count + 1)
         If Not Dic.exists(Cl.Value) Then Dic.Add Cl.Value, Nothing
      Next Cl
      Rng.Offset(-1, -1).Resize(1).Value = Join(Dic.keys, ",")
      Dic.removeall
   Next Rng
   Range("B:B").SpecialCells(xlBlanks).EntireRow.Delete
      
End Sub

 

[mkrlhd]

Awesome thank you very much for your help...

 

[Fluff]

Glad t help & thanks for the feedback