Sub movsort()
Dim sht As Worksheet
With Worksheets("Sheet1")
lastrow = .Cells(Rows.Count, "A").End(xlUp).Row
inarr = Range(.Cells(1, 1), .Cells(lastrow, 3))
Range(.Cells(1, 4), .Cells(lastrow, 4)) = ""
outarr = Range(.Cells(1, 4), .Cells(lastrow, 4))
End With
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "TempSheet"
Range(Cells(1, 1), Cells(lastrow, 3)) = inarr
Range(Cells(lastrow + 1, 1), Cells((2 * lastrow), 3)) = inarr
temp3 = Range(Cells(1, 3), Cells(lastrow, 3))
Range(Cells(lastrow + 1, 2), Cells((2 * lastrow), 2)) = temp3
Set myrange = Range(Cells(1, 1), Cells((2 * lastrow), 3))
Set Sortkey = Range(Cells(1, 2), Cells((2 * lastrow), 2))
myrange.Sort key1:=Sortkey, order1:=xlAscending, MatchCase:=False, Header:=xlYes
flsd = Range(Cells(1, 1), Cells((2 * lastrow), 3))
For i = 1 To lastrow
com = "'"
For j = 1 To (2 * lastrow)
If inarr(i, 2) = flsd(j, 2) Then
outarr(i, 1) = outarr(i, 1) & com & flsd(j, 1)
com = ","
End If
Next j
Next i
Application.DisplayAlerts = False
Set sht = Worksheets("Tempsheet")
sht.Delete
Application.DisplayAlerts = True
With Worksheets("Sheet1")
Range(.Cells(1, 4), .Cells(lastrow, 4)) = outarr
End With
End Sub