maybe so
Sub ertert()
Dim x, y(), i&, j&, k&
x = Sheets("Sheet1").Range("A1").CurrentRegion.Value
ReDim y(1 To UBound(x) * 3, 1 To 3)
With CreateObject("Scripting.Dictionary")
.CompareMode = 1
For i = 1 To UBound(x)
For j = 1 To UBound(x, 2)
If .Exists(x(i, j)) Then
y(.Item(x(i, j)), j) = x(i, j)
Else
k = k + 1: .Item(x(i, j)) = k
y(k, j) = x(i, j)
End If
Next j
Next i
End With
With Sheets("Sheet2").Range("A1").CurrentRegion
.ClearContents: .Resize(k, UBound(x, 2)).Value = y()
.Parent.Activate
End With
End Sub
Bookmarks