Each unique Entries and their corresponding values should get concatenate with uniqueness,Attached macro working correctly but not efficient,I need some suggestion to avoid the Multiple if checks and , Is it possible to create dictionary objects with loops. I want to automate this too.


Sub Working_With_Dic()

Application.ScreenUpdating = False

Set Dc = CreateObject("Scripting.dictionary")
Set Dc1 = CreateObject("Scripting.dictionary")
Set Dc2 = CreateObject("Scripting.dictionary")
Set Dc3 = CreateObject("Scripting.dictionary")

Dc.RemoveAll
Dc1.RemoveAll
Dc2.RemoveAll
Dc3.RemoveAll


For i = 1 To 1085
If Not Dc.Exists(Cells(i, 1).Value) Then
Dc.Add Cells(i, 1).Value, Cells(i, 2).Value
Dc1.Add Cells(i, 1).Value, Cells(i, 3).Value
Dc2.Add Cells(i, 1).Value, Cells(i, 4).Value
Dc3.Add Cells(i, 1).Value, Cells(i, 5).Value

Else
If InStr(1, Dc.Item(Cells(i, 1).Value), Cells(i, 2).Value, vbBinaryCompare) = 0 Then
Dc.Item(Cells(i, 1).Value) = Dc.Item(Cells(i, 1).Value) & "+" & Cells(i, 2).Value
End If

If InStr(1, Dc1.Item(Cells(i, 1).Value), Cells(i, 3).Value, vbBinaryCompare) = 0 Then
Dc1.Item(Cells(i, 1).Value) = Dc1.Item(Cells(i, 1).Value) & "+" & Cells(i, 3).Value
End If

If InStr(1, Dc2.Item(Cells(i, 1).Value), Cells(i, 4).Value, vbBinaryCompare) = 0 Then
Dc2.Item(Cells(i, 1).Value) = Dc2.Item(Cells(i, 1).Value) & "+" & Cells(i, 4).Value
End If

If InStr(1, Dc3.Item(Cells(i, 1).Value), Cells(i, 5).Value, vbBinaryCompare) = 0 Then
Dc3.Item(Cells(i, 1).Value) = Dc.Item(Cells(i, 1).Value) & "+" & Cells(i, 5).Value
End If

End If
Next

i = 1
For Each k In Dc.keys
With Sheets("Sheet2")
.Cells(i, 1) = k
.Cells(i, 2) = Dc.Item(k)
.Cells(i, 3) = Dc1.Item(k)
.Cells(i, 4) = Dc2.Item(k)
.Cells(i, 5) = Dc3.Item(k)
End With
i = i + 1
Next
End Sub