Nejprve bych na začátku zavedl zkratku na hlavní list "Přehled", abych na něj mohl snáze odkazovat:

Set wsPrehled = ThisWorkbook.Worksheets("Přehled")

Pak bych zjednodušil mazání všech listů (s výjimkou právě Přehledu) do cyklu přes všechny listy:

For Each ws In ActiveWorkbook.Worksheets
  If ws.Name <> wsPrehled.Name then
    ws.Range("B3:K1000").ClearContents
  End If
Next ws

Už dříve jsem psal, že ty Case ani nepotřebuješ a celé kopírování můžeš značně zjednodušit. Musíš si ale vytvořit funkci testující existenci sešitu (TestSheetExist). Navíc se vyhýbej používání Select, raději používej Activate:

Function TestSheetExist(TestSheetName As String) As Boolean
  On Error Resume Next ' error handler-zamezí vzniku chyby
  Set wsSheet = Worksheets(TestSheetName)
  TestSheetExist = True  ' předpokládám existenci listu
  If Err.Number <> 0 Then ' chyba vznikla --> list neexistuje
    TestSheetExist = False
  End If
  On Error GoTo 0  ' zapne standardní zachytávání chyb
End Function

Skupina = Cells(i, 10)
If not TestSheetExist(Skupina) Then  ' List neexistuje - kopíruji na "NEZAŘAZENO"
  Skupina = "NEZAŘAZENO"
End If
wsPrehled.Range(Cells(i, 2), Cells(i, 11)).Copy 
Sheets(Skupina).Activate
x = Range("B1").End(xlDown).Row + 1
Cells(x, 2).Activate
ActiveSheet.Paste
wsPrehled.Activate

Něco o zlozvyku používat Select místo Activate.

Napadá mě i další vylepšení - vést si pole s čísly volných řádků pro všechny listy - vyhneš se tak zjišťování prvního volného řádku v každém kroku cyklu.