Hi Mandeep,

Am Thu, 3 Dec 2015 21:17:04 -0800 (PST) schrieb Mandeep Baluja:

Output :-
1, 2 a, b, d c, d, e, f, g k, B, T

But i want is :-
1 b,a,d d,e,f,g B,T k,b,t
2 a,b,d c,d,e,f,g k,B,T

now I got it ;-)
Try this (a little bit faster than your code):

Sub Test()
Dim varData As Variant, varOut() As Variant
Dim varTmp() As Variant, varTmp2 As Variant
Dim i As Long, j As Long, k As Long, LRow As Long
Dim myDic As Object, myDic2 As Object
Dim key As String, myStr As String

Sheets("Sheet2").UsedRange.ClearContents

With Sheets("Sheet1")
LRow = .Cells(Rows.Count, 1).End(xlUp).Row
If myDic Is Nothing Then _
Set myDic = CreateObject("Scripting.Dictionary")
varData = .Range("A1:D" & LRow)
For i = LBound(varData) To UBound(varData)
key = varData(i, 1) & "," & varData(i, 2) & "," _
& varData(i, 3) & "," & varData(i, 4)
If Not myDic.Exists(key) Then
myDic(key) = i
ReDim Preserve varOut(j)
varOut(j) = key
j = j + 1
End If
Next

ReDim Preserve varTmp(UBound(varOut), 3)
For i = LBound(varOut) To UBound(varOut)
For j = 0 To 3
varTmp(i, j) = Split(varOut(i), ",")(j)
Next
Next

If myDic2 Is Nothing Then _
Set myDic2 = CreateObject("Scripting.Dictionary")
For i = LBound(varTmp) To UBound(varTmp)
key = varTmp(i, 0)
If Not myDic2.Exists(key) Then
myDic2(key) = i
End If
Next
varTmp2 = myDic2.keys
Sheets("Sheet2").Range("A1").Resize(UBound(varTmp2 ) + 1) = _
Application.Transpose(varTmp2)

For j = 1 To 3
For k = LBound(varTmp2) To UBound(varTmp2)
For i = LBound(varTmp) To UBound(varTmp)
If varTmp(i, 0) = varTmp2(k) Then
If myStr = "" Then myStr = varTmp(i, j)
If InStr(myStr, varTmp(i, j)) = 0 Then myStr = myStr
& ", " & varTmp(i, j)
End If
Next
Sheets("Sheet2").Cells(k + 1, j + 1) = myStr
myStr = ""
Next
Next
End With
Sheets("Sheet2").Columns("A:D").AutoFit
End Sub

Regards
Claus B.
--
Vista Ultimate / Windows7
Office 2007 Ultimate / 2010 Professional