Multiple Rows to one Row

Sub RunMe()
Dim sSheet, dSheet As Worksheet
Dim x, y As Integer
'Source and Destination sheets. Adjust to match yours.
Set sSheet = Sheets("Sheet1")
Set dSheet = Sheets("Sheet2")
x = 5

sSheet.Range("A5:D" & sSheet.Range("A5").End(xlDown).Row).Copy dSheet.Range("A5")
dSheet.Range("A5:D" & dSheet.Range("A5").End(xlDown).Row).RemoveDuplicates Columns:=Array(1, 2, 3, 4), Header:=xlNo

For Each cell In dSheet.Range("A5:A" & Range("A" & Rows.Count).End(xlUp).Row)
    Do
        If cell.Value = sSheet.Range("A" & x).Value Then
        y = 5
            Do
                If sSheet.Range("E" & x).Value = dSheet.Cells(2, y).Value Then Exit Do
                y = y + 6
            Loop Until dSheet.Cells(2, y).Value = vbNullString
            sSheet.Range(sSheet.Cells(x, "F"), sSheet.Cells(x, "K")).Copy dSheet.Cells(cell.Row, y)
        End If
        x = x + 1
    Loop Until cell.Value <> sSheet.Range("A" & x).Value
Next cell
End Sub