Sub kopiuj()
Dim a As Long
Dim b As Integer
With Worksheets("Arkusz1") 'zakładam że lista jest w arkusz1
'sprawdzenie czy arkusz istnieje, gdy brak dodanie
For a = 1 To .Range("A65536").End(xlUp).Row
    For b = 1 To Worksheets.Count
        If UCase(.Cells(a, 1)) = UCase(Worksheets(b).Name) Then Exit For
    Next b
    If b = Worksheets.Count + 1 Then
        Worksheets.Add after:=Worksheets(Worksheets.Count)
        ActiveSheet.Name = .Cells(a, 1)
    End If
Next a
'właściwe kopiowanie
For a = 1 To .Range("A65536").End(xlUp).Row
.Range(.Cells(a, 1), .Cells(a, 2)).Copy Worksheets(.Cells(a, 1).Text).Range("A65536").End(xlUp).Offset(1, 0)
Next a
End With
End Sub