Dodawanie zakładek z nazwami z zakresu z filtrowaniem

Private Sub ble()
Dim wbBook As Workbook
Dim wsSheet As Worksheet
Dim rnStart As Range
Dim rnData As Range
Dim i As Long

Application.ScreenUpdating = False

On Error GoTo myErr

Set wbBook = ThisWorkbook
Set wsSheet = wbBook.Worksheets("asa")

With wsSheet
    Set rnData = .Range(.Range("A1"), .Cells(.Rows.Count, 1).End(xlUp)) 'zakres z danymi (z nagłowkiem)
    Set rnFiltr = .Range(.Range("A2"), .Cells(.Rows.Count, 1).End(xlUp))    'zakres do filtrowania
End With


Dim tabl() As String
ReDim tabl(1 To rnData.Rows.Count)

ile_w_tabl = 0

For Each c In rnFiltr
    wiersz = 0
    dodaj = True
    'szukamy czy już nie filtrowaliśmy po tej wartości
    For i = 1 To ile_w_tabl
        If tabl(i) = c Then     'jeżeli tak - przechodzimy dalej
            dodaj = False
            Exit For
        End If
    Next i
   
    If dodaj = True Then
        'dodajemy kolejną komórkę do tablicy
        ile_w_tabl = ile_w_tabl + 1
        tabl(ile_w_tabl) = CStr(c)
           
        'tworzymy nowy arkusz
        wbBook.Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = c
        Set wsNowy = wbBook.Worksheets(CStr(c))
           
        'filtrujemy po tej wartości: wyszukujemy kolejne w zakresie i kopiujemy je do nowego arkusza
        Dim iLoop As Integer
        Dim rCell As Range
        Set rCell = rnData(1, 1)    'pierwsza komórka do przeszukiwania
        ile_wyst = WorksheetFunction.CountIf(Columns(1), c)
       
        For iLoop = 1 To ile_wyst
            Set rCell = rnData.Columns(1).Find(What:=c, After:=rCell, _
            LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
            SearchDirection:=xlNext, MatchCase:=False)
            
             If Not rCell Is Nothing Then
                wiersz = wiersz + 1
                wsSheet.Range("A" & rCell.Row & ":C" & rCell.Row).Copy Destination:=wbBook.Sheets(CStr(c)).Range("A" & wiersz)
             End If
        Next iLoop
    End If
Next c

With Application
    .CutCopyMode = False
    .ScreenUpdating = True
End With

MsgBox "Koniec", vbInformation + vbOKOnly, "OK"

On Error GoTo 0

Exit Sub
   
myErr:
    Application.ScreenUpdating = True
    MsgBox "Błąd podczas działania makra", vbCritical + vbOKOnly, "Błąd"

End Sub

zaczerpnięte z http://www.elektroda.pl/rtvforum/topic1653808.html