A sütünunda aynı olan satırları farklı sayfaya kopyalama

[okanaytimur]

Merhaba linkteki dosya da A sütununda aynı olan hücreleri seçip yeni sayfaya taşımak istiyorum.
Elimde aşağıdaki gibi girilen sayı miktarında satırı kesip yeni sayfaya ekleyen bir kod var. Inputbox ile tekrar sayısını alıyor bir for döngüsü ile dosya bitene kadar o aralığı seçip yeni sayfa oluşturup oraya taşıyor. Bunu hücre değerine göre yapmasını nasıl sağlarım ?
Örneğin A1 den A20 ye kadar AFK33 yazıyor bu 20 satır Sayfa2 ye taşısın sonra A21-A200 arasında ADEL yazıyor bu 179 satırı Sayfa3 e taşısın.

Sub KesYeniSayfaYapistir()
'
' KesYeniSayfaYapistir Makro
'
' Klavye Kısayolu: Ctrl+Shift+W
'
 
Dim bir, iki As String

    Aralik = InputBox("Kaç satır da da bir: ", "Başla", Default)
    AnaSayfa = ActiveSheet.Name
    SatirSayisi = ActiveSheet.UsedRange.Rows(ActiveSheet.UsedRange.Rows.Count).Row
 
    For i = 1 To SatirSayisi
        c = i + Aralik
        Kesilecek = "A" + CStr(i) + ":" + "A" + CStr(c)
        ActiveSheet.Range(Kesilecek).Cut

        Sheets.Add After:=ActiveSheet
        ActiveSheet.Paste
        Application.CutCopyMode = False

        Worksheets(AnaSayfa).Activate
        i = i + Aralik
        Next

End Sub

 

[veyselemre]

Sub test()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    Dim s1 As Worksheet, son&, i&, bolumler, al, say&, lst, ky$, sh As Worksheet, marka$
    
    Set s1 = Sheets("LL")
    s1.Select
    
    son = s1.Cells(Rows.Count, 1).End(3).Row
    Range("A1:BL" & son).Sort Range("A1"), , , , , , , xlYes
    
    lst = Range("A1:A" & son).Value
    
    ReDim bolumler(1 To UBound(lst), 1 To 3)
    
    With CreateObject("Scripting.Dictionary")
        .comparemode = 1
        For i = 2 To UBound(lst)
            ky = Split(lst(i, 1), " ")(0)
            If Not .exists(ky) Then
                say = say + 1
                bolumler(say, 1) = ky
                bolumler(say, 2) = i
                bolumler(say, 3) = i
                .Item(ky) = say
            Else
                al = .Item(ky)
                bolumler(al, 3) = i
            End If
        Next i
        .RemoveAll
        
        For Each sh In Worksheets
            .Item(sh.Name) = Null
        Next
    
        For i = 1 To say
            marka = bolumler(i, 1)
            If .exists(marka) Then Sheets(marka).Delete
            Sheets.Add(after:=ActiveSheet).Name = marka
            s1.Range("1:1").Copy ActiveSheet.Range("A1")
            s1.Range(bolumler(i, 2) & ":" & bolumler(i, 3)).Copy ActiveSheet.Range("A2")
            ActiveSheet.Columns.AutoFit
        Next i
    
    End With

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
 
End Sub

 

[okanaytimur]

Sub test()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
   
    Dim s1 As Worksheet, son&, i&, bolumler, al, say&, lst, ky$, sh As Worksheet, marka$
   
    Set s1 = Sheets("LL")
    s1.Select
   
    son = s1.Cells(Rows.Count, 1).End(3).Row
    Range("A1:BL" & son).Sort Range("A1"), , , , , , , xlYes
   
    lst = Range("A1:A" & son).Value
   
    ReDim bolumler(1 To UBound(lst), 1 To 3)
   
    With CreateObject("Scripting.Dictionary")
        .comparemode = 1
        For i = 2 To UBound(lst)
            ky = Split(lst(i, 1), " ")(0)
            If Not .exists(ky) Then
                say = say + 1
                bolumler(say, 1) = ky
                bolumler(say, 2) = i
                bolumler(say, 3) = i
                .Item(ky) = say
            Else
                al = .Item(ky)
                bolumler(al, 3) = i
            End If
        Next i
        .RemoveAll
       
        For Each sh In Worksheets
            .Item(sh.Name) = Null
        Next
   
        For i = 1 To say
            marka = bolumler(i, 1)
            If .exists(marka) Then Sheets(marka).Delete
            Sheets.Add(after:=ActiveSheet).Name = marka
            s1.Range("1:1").Copy ActiveSheet.Range("A1")
            s1.Range(bolumler(i, 2) & ":" & bolumler(i, 3)).Copy ActiveSheet.Range("A2")
            ActiveSheet.Columns.AutoFit
        Next i
   
    End With

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True

End Sub

Hocam çok teşekkür ederim. Tam olması gerektiği gibi çalıştı. Ellerinize sağlık.