Sub uuu()
    Dim a(), b()
    Dim i&, j&
    Dim sd As Object
    Dim k
'-------------------
    Application.ScreenUpdating = False
    a = Sheets(1).UsedRange.Value
    Set sd = CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(a)
        k = a(i, 1)
        If sd.Exists(k) Then
            b = sd.Item(k)
            For j = 1 To UBound(a, 2)
                If a(i, j) <> "" Then b(j) = a(i, j)
            Next
            sd.Item(k) = b
        Else
            sd.Item(k) = Application.Index(a, i)
        End If
    Next
    Sheets.Add After:=Sheets(Sheets.Count)
    i = 1
    For Each k In sd.Keys
        b = sd.Item(k)
        Cells(i, 1).Resize(1, UBound(b)) = b
        i = i + 1
    Next
    For i = 1 To 4
        ActiveSheet.UsedRange.Borders(i).LineStyle = xlContinuous
    Next
    Application.ScreenUpdating = True
    Beep
    MsgBox "Готово!"
End Sub