Hi Mandeep,

Am Sun, 6 Dec 2015 23:09:51 -0800 (PST) schrieb Mandeep Baluja:

This is something amazing,Gud work Logic was same but the use of array is brilliantly done !!!
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^

at the position above the array varOut is superfluous.
Try it this way:

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
Dim st As Double
st = Timer

Application.ScreenUpdating = False
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
End If
Next

varTmp = myDic.keys

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

If myDic2 Is Nothing Then _
Set myDic2 = CreateObject("Scripting.Dictionary")
For i = LBound(varOut) To UBound(varOut)
key = varOut(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(varOut) To UBound(varOut)
If varOut(i, 0) = varTmp2(k) Then
If myStr = "" Then myStr = varOut(i, j)
If InStr(myStr, varOut(i, j)) = 0 Then myStr = myStr
& ", " & varOut(i, j)
End If
Next
Sheets("Sheet2").Cells(k + 1, j + 1) = myStr
myStr = ""
Next
Next
End With
Sheets("Sheet2").Columns("A:D").AutoFit
Application.ScreenUpdating = True
MsgBox Format(Timer - st, "0.000")
End Sub



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