Sub Demo()
Application.ScreenUpdating = False
Dim lRow As Long, lCol As Long, i As Long, j As Long
Dim xlWkBk As Workbook, xlSht As Worksheet, StrSht As String
Set xlWkBk = ThisWorkbook: StrSht = ""
Set xlSht = xlWkBk.Worksheets("Sheet1")
With xlWkBk.Worksheets("Sheet1").UsedRange
  lRow = .Range("A" & .Cells.SpecialCells(xlCellTypeLastCell).Row).End(xlUp).Row
  lCol = .Cells.SpecialCells(xlCellTypeLastCell).Column
  For i = 1 To lRow
    Select Case .Cells(i, 1).Text
      Case "CY"
        StrSht = "CY": j = 0
        Set xlSht = xlWkBk.Sheets.Add(After:=xlSht)
        xlSht.Name = StrSht
      Case "DL"
        StrSht = "DL": j = 0
        Set xlSht = xlWkBk.Sheets.Add(After:=xlSht)
        xlSht.Name = StrSht
      Case "EU"
        StrSht = "EU": j = 0
        Set xlSht = xlWkBk.Sheets.Add(After:=xlSht)
        xlSht.Name = StrSht
    End Select
    If StrSht <> "" Then
      j = j + 1
      .Range(.Cells(i, 1), .Cells(i, lCol)).Copy
      xlSht.Paste Destination:=xlSht.Cells(j, 1)
    End If
  Next
End With
Application.ScreenUpdating = True
End Sub