Sub NomenSort()
  Const Divizor As String = "###"
  Application.ScreenUpdating = False
  Dim Sh As Worksheet
  Set Sh = ActiveSheet
  For Index& = Sh.UsedRange.Rows.Count To  2  Step - 1 
    If Sh.Cells(Index,  1 ) = Divizor And Sh.Cells(Index -  1 &,  1 ) = Divizor Then _
      Sh.Rows(Index).Delete
  Next
  For Index& =  2  To Sh.UsedRange.Rows.Count Step  3 
    Row& = Row& +  1 &
    Name$ = Sh.Cells(Index,  1 )
    Sh.Cells(Row,  2 ) = Name
    Sh.Cells(Row,  3 ) = Sh.Cells(Index +  1 &,  1 )
    Sh.Cells(Row,  4 ) = Left(Name, InStr(Name, ":") -  1 &)
  Next
  With Sh.Range(Sh.Cells( 1 ,  2 ), Sh.Cells(Row,  4 ))
    .Sort [D1]
    For Row& =  1  To Row
      Index = Row *  3  -  1 &
      Sh.Cells(Index,  1 ) = Sh.Cells(Row,  2 )
      Sh.Cells(Index +  1 &,  1 ) = Sh.Cells(Row,  3 )
    Next
    .Delete
  End With
  Application.ScreenUpdating = True
End Sub