Populate multiple Sheets

Sub CreateWorksheet()
Dim var As Variant
Dim dept As String
Dim lX As Long
Dim iCols As Integer

iCols = ActiveSheet.UsedRange.Columns.Count
ActiveSheet.UsedRange.Select
Selection.Sort Key1:=Range("B1"), Order1:=xlAscending, Key2:=Range("C1") _
    , Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
    False, Orientation:=xlTopToBottom

Range(Cells(1, 2), Cells(ActiveSheet.UsedRange.Rows.Count, 2)).Select


For Each var In Selection
  If Trim$(var.Value) = "" Then Exit For
  If dept <> var.Value Then
    Sheets.Add
    ActiveSheet.Name = var.Value
    dept = var.Value
    lX = 0
  End If
  lX = lX + 1
  Sheets("Sheet1").Activate
  Sheets("Sheet1").Range(Cells(var.Row, 1), Cells(var.Row, iCols)).Copy _
    Destination:=Sheets(dept).Cells(lX, 1)
' ActiveSheet.Cells(lX, 1).Value = Sheets("Sheet1").Range(Cells(var.Row, 2), Cells(var.Row, iCols)).Value
Next var
End Sub

Delete mulitple sheets
Sub DeleteSheets()
Dim ws As Worksheet
Application.DisplayAlerts = False
For Each ws In Worksheets
'If ws.Name <> "Sheet1" And ws.Name <> "Sheet2" Then ws.Delete
If ws.Name <> "Sheet1" Then ws.Delete
Next
Application.DisplayAlerts = True
End Sub