VBA to compare duplicates and add in same rows

[rajesh2022]

Hello All

We are in the process building a logic which is as follows:

1. We are having 2 columns which contains duplicate values as well. For example

Name	Value
Rajesh	Tech Lead
Ramesh	Supervisor
Rajesh	Manager
Rajesh	Store Keeper
Rob	Manager
Rob	Store Keeper
Rob	Tech Lead

I need to create another column which needs to check for duplicate and add as below : (Expected Output)

Name	Value	Output 1	Output 2
Rajesh	Tech Lead	Manager	Store Keeper
Ramesh	Supervisor
Rajesh	Manager	Tech Lead	Store Keeper
Rajesh	Store Keeper	Manager	Tech Lead
Rob	Manager	Store Keeper	Tech Lead
Rob	Store Keeper	Manager	Tech Lead
Rob	Tech Lead	Manager	Store Keeper

Basically i don't want to delete duplicates, but i want to show in another columns,

Can we achieve in VBA? Any guidance would be great

 

[Marc L]

Hello,​

​

it shoud be achieved with differents ways, like using Excel basics or some activeX like a Dictionary.​

But as it depends on the real worksheet …​

​

 

[rajesh2022]

Thanks, adding worksheet to this thread.

 

[Marc L]

According to your attachment why "Okta-NewgenOneFlow-PRDUsers" is not in the expected result ?!​

​

 

[rajesh2022]

I am so sorry, i deleted that 2 rows from Input.

 

[Marc L]

According to your attachment a VBA demonstration for starters :​

Sub Demo1()
        Dim Dic As Object, V, R&, W
        Set Dic = CreateObject("Scripting.Dictionary")
        Application.ScreenUpdating = False
    With Sheet1.UsedRange.Columns
            V = .Item("A:B").Value2
            If .Count > 2 Then .Item(3).Resize(, .Count - 2).Clear
        For R = 2 To .Rows.Count
            If Dic.Exists(V(R, 1)) Then
                W = Dic(V(R, 1))
                ReDim Preserve W(UBound(W) + 1)
                W(UBound(W)) = V(R, 2)
                Dic(V(R, 1)) = W
            Else
                Dic(V(R, 1)) = Array(V(R, 2))
            End If
        Next
        For R = 2 To .Rows.Count
            W = Filter(Dic(V(R, 1)), V(R, 2), False)
            If UBound(W) > -1 Then .Cells(R, 3).Resize(, UBound(W) + 1).Value2 = W
        Next
    End With
        Dic.RemoveAll
        Set Dic = Nothing
    With Sheet1.UsedRange.Columns
        If .Count > 2 Then
            With .Item(3).Resize(, .Count - 2)
                 .Borders.Weight = 2
                 .Rows(1).Interior.ColorIndex = 36
                 .Rows(1).HorizontalAlignment = xlCenter
                 .Rows(1).Value2 = Evaluate("COLUMN(A1:" & Cells(.Count).Address & ")")
            End With
        End If
           .AutoFit
           .VerticalAlignment = xlCenter
    End With
        Application.ScreenUpdating = True
End Sub

Do you like it ? So thanks to click on bottom right Like !
​

 

[rajesh2022]

Worked like charm, thanks