Need help merging rows..

Hi bryn022
try it

Sub ertert()
Dim x, y(), s$, i&, j&, k&, n&, ubx&
x = Sheets("Sheet1").Range("A1").CurrentRegion.Value: ubx = UBound(x, 2)
ReDim y(1 To UBound(x, 1), 1 To ubx)
With CreateObject("Scripting.Dictionary")
    .CompareMode = 1
    For i = 1 To UBound(x)
        s = Join(Array(x(i, 1), x(i, 2), x(i, 3), x(i, 4), x(i, 5)), "~")
        If .Exists(s) Then
            k = .Item(s)
            For n = 1 To ubx
                If IsEmpty(y(k, n)) Then y(k, n) = x(i, n)
            Next n
        Else
            j = j + 1: .Item(s) = j
            For k = 1 To ubx: y(j, k) = x(i, k): Next k
        End If
    Next i
End With
With Sheets("Sheet2")
    .UsedRange.ClearContents
    .Range("A1").Resize(j, ubx).Value = y()
    .Activate
End With
End Sub