Grupları sırasıyla dağıtmak

[tahsinanarat]

Ekli liste de gönderdiğim Sayfa1 de kayıtlı personel listesini, Sayfa2 de D Sutununda gbupları A,B,C,D şeklinde devam edecek, hangi harf diğerlerinden önce biterse
o sıra boş kalarak grup sayısı bitene kadar devam edecek GÜNDÜZ ve MEMUR yazan satırlar sıralamada yer olmayacaklar.
Yardımcı olacak arkadaşlarıma şimdiden teşekkür ederim.

 

[ÖmerBey]

Merhaba Tahsin Bey,
Aşağıdaki kodları deneyiniz.

Sub kod()
Dim a As Integer, b As Integer, c As Integer, d As Integer, i As Integer, sat As Integer
Dim s1 As Worksheet, s2 As Worksheet, grup As String
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
s2.Range("A2:D10000").ClearContents
For i = 2 To s1.Cells(Rows.Count, "C").End(3).Row
    grup = s1.Cells(i, "C")
    Select Case grup
        Case "A"
            sat = a * 4 + 2
            a = a + 1
        Case "B"
            sat = b * 4 + 3
            b = b + 1
        Case "C"
            sat = c * 4 + 4
            c = c + 1
        Case "D"
            sat = d * 4 + 5
            d = d + 1
        Case Else
            sat = 0
    End Select
    
    If sat > 0 Then
        s2.Cells(sat, "B") = s1.Cells(i, "A")
        s2.Cells(sat, "C") = s1.Cells(i, "B")
        s2.Cells(sat, "D") = s1.Cells(i, "C")
    End If
Next

With s2.Range("A2:A" & s2.Cells(Rows.Count, "B").End(3).Row)
    .Formula = "=ROW()-1"
    .Value = .Value
End With

End Sub

 

[veyselemre]

Alternatif;

Sub siraliGetir()
    Dim col(1 To 4) As New Collection
    Set s1 = Sheets("Sayfa1")
    Set s2 = Sheets("Sayfa2")
    s2.Range("A2:D" & Rows.Count).ClearContents

    For i = 2 To s1.Cells(Rows.Count, "C").End(3).Row
        al = Asc(s1.Cells(i, 3).Value) - 64
        If al > 0 And al < 5 Then col(al).Add s1.Cells(i, 1).Resize(, 3).Value
    Next i

    For i = 1 To 4
        If col(i).Count > mx Then mx = col(i).Count
    Next i

    For ii = 1 To mx
        For i = 1 To 4
            sat = sat + 1
            s2.Cells(sat + 1, "A").Value = sat
            If ii <= col(i).Count Then
                s2.Cells(sat + 1, "B").Resize(, 3).Value = col(i).Item(ii)
            End If
        Next i
    Next ii
    
    Set col(1) = Nothing
    Set col(2) = Nothing
    Set col(3) = Nothing
    Set col(4) = Nothing
End Sub

 

[tahsinanarat]

Sn. Ömer hocam ve Sn. veyselemre hocam her iki kodda mükemmel çalıştı, elleriniz dert görmesin, çok çok teşekkür ederim.