Soru Toplu listeden sayfalara dağıtmak.

[lovecaroline]

Saygıdeğer hocalarım ve değerli arkadaşlar,
Elimdeki excel dosyasında; toplu bir liste (TÜMÜ) ve bir çok sınıf var. Bu listedeki satır sayısı değişkenlik göstermekte, çok fazla veya çok az olabilmektedir.
İsteğim; TÜMÜ adlı sayfada yer alan kişilerin kendi sınıflarına ait sayfalara sırasıyla yerleşmesidir. Bütün sınıflarda NO sütunu 1’den başlamalıdır.
Sonuç olarak istediğimi anlatan örnek bir sayfada dosyaya ekledim.
Yardımcı olabilirseniz çok sevinirim. Şimdiden teşekkürler.

 

[Ziynettin]

Çalışma ekte.

 

[lovecaroline]

Emeğiniz için teşekkür ederim. Ama istediğim bu şekilde değil.
Belki de ben izah edemedim.
Amacım sayfaları açmak değil. Zaten sayfalar hali hazırda mevcut. Ben; tüm sınıfların olduğu ilk listeden, 6A olanları 6A'ya; 6B olanları 6B'ye; 6C olanları da 6C'ye aktarsın istiyorum.
Her bir sınıf için NO 1'den başlayarak ilerlesin.
Sonuç olarak: verdiğim listeyi düşünürsek 6A: 50 öğrenci, 6B: 100 Öğrenci ve 6C 150 öğrenci olacak.
Not: Liste artabilir, sınıflar artabilir. (Listede ne kadar sınıf varsa o kadar liste oluşacak)
Şimdiden teşekkürler.

 

[Necdet]

Merhaba,

Dener misiniz? Sayfaların var olduğu varsayımıyla sayfa kontrolü yapılmadı.

Sub Sayfalara_Aktar()

    Dim d, _
        k   As Variant, _
        deg As Variant, _
        i   As Integer, _
        j   As Long, _
        r   As Long, _
        sh  As Worksheet
   
    Set sh = Sheets("TÜMÜ")
    sh.Select
   
    j = sh.Cells(Rows.Count, "A").End(3).Row
   
    Set d = CreateObject("Scripting.Dictionary")
   
    For i = 2 To [a1000].End(3).Row
        deg = Cells(i, "G")
        If Not d.exists(deg) Then d.Add deg, ""
    Next i
   
    k = d.keys
   
    For i = 0 To d.Count - 1
        sh.Range("$A$1:$G$301").AutoFilter Field:=7, Criteria1:=k(i)
        sh.Range("A1").CurrentRegion.Copy Sheets(k(i)).Range("B8")
        r = Sheets(k(i)).Cells(Rows.Count, "B").End(3).Row
        With Sheets(k(i))
            .Range("B9") = 1
            .Range("B10") = 2
            .Range("B9:B" & r).DataSeries
        End With
       
    Next i
           
    sh.Range("A1").AutoFilter
   
End Sub

 

[Muzaffer Ali]

Bu da benden alternatif olsun.

Sub Aktar()
    Dim SiraNo As Integer
    Dim syfYeni As Worksheet
    Dim syfTumu As Worksheet
    Dim Siniflar As Variant
    Dim Sinif As Integer
    
    Set syfTumu = Worksheets("TÜMÜ")
    Set syfYeni = Sheets.Add
    syfTumu.Range("G:G").Copy syfYeni.Range("A1")
    syfYeni.Range("A:A").RemoveDuplicates Columns:=1, Header:=xlYes
    Siniflar = syfYeni.Range("A2:A" & syfYeni.Cells(Rows.Count, "A").End(xlUp).Row)
    For Sinif = 1 To UBound(Siniflar)
        With syfTumu
            .Range("A:G").AutoFilter Field:=7
            .Range("A:G").AutoFilter Field:=7, Criteria1:=Siniflar(Sinif, 1), Operator:=xlFilterValues
            Worksheets(Siniflar(Sinif, 1)).Range("B9:F" & Rows.Count).ClearContents
            .Range("A2:E" & .Cells(Rows.Count, "A").End(xlUp).Row).Copy Worksheets(Siniflar(Sinif, 1)).Range("B9")
        End With
        With Worksheets(Siniflar(Sinif, 1))
            For SiraNo = 9 To .Cells(Rows.Count, "B").End(xlUp).Row
                .Cells(SiraNo, "B") = SiraNo - 8
            Next
        End With
    Next
    Application.DisplayAlerts = False
    syfYeni.Delete
    Application.DisplayAlerts = True
    syfTumu.ShowAllData
    Set syfTumu = Nothing
    Set syfYeni = Nothing
    MsgBox "Aktarımı tamamlandı."
End Sub

 

[Ziynettin]

Emeğiniz için teşekkür ederim. Ama istediğim bu şekilde değil.
Belki de ben izah edemedim.
Amacım sayfaları açmak değil. Zaten sayfalar hali hazırda mevcut. Ben; tüm sınıfların olduğu ilk listeden, 6A olanları 6A'ya; 6B olanları 6B'ye; 6C olanları da 6C'ye aktarsın istiyorum.
Her bir sınıf için NO 1'den başlayarak ilerlesin.
Sonuç olarak: verdiğim listeyi düşünürsek 6A: 50 öğrenci, 6B: 100 Öğrenci ve 6C 150 öğrenci olacak.
Not: Liste artabilir, sınıflar artabilir. (Listede ne kadar sınıf varsa o kadar liste oluşacak)
Şimdiden teşekkürler.

Sub test()
Dim s1 As Worksheet
Set dc = CreateObject("scripting.dictionary")
Set s1 = Sheets("TÜMÜ")
Application.ScreenUpdating = False

son = s1.Range("G" & Rows.Count).End(3).Row
a = s1.Range("A1:G" & son).Value

    For i = 2 To UBound(a)
        If a(i, 7) <> "" Then dc(a(i, 7)) = ""
    Next i
    
sh = dc.keys

    For x = 0 To dc.Count - 1
        ReDim b(1 To UBound(a), 1 To 5)
        On Error Resume Next
        Set s2 = Sheets(sh(x))
        On Error GoTo aa
            For i = 1 To UBound(a)
                krt = a(i, 7)
                If s2.Name = krt Then
                    say = say + 1
                    b(say, 1) = say
                    b(say, 2) = a(i, 2)
                    b(say, 3) = a(i, 3)
                    b(say, 4) = a(i, 4)
                    b(say, 5) = a(i, 5)
                End If
            Next i
        If say > 0 Then
            s2.Range("B9:F" & Rows.Count).ClearFormats
            s2.Range("B9:F" & Rows.Count).ClearContents
            s2.[B9].Resize(say, 5) = b
            s2.[B9].Resize(say, 5).Borders.Color = rgbGrey
        End If
aa: say = 0
    Next x
    
s1.Select
Application.ScreenUpdating = True
MsgBox "İşlem bitti...", vbInformation
End Sub