aşağıdaki procedürü forma ekleyip ister butondan ister "Form geçerli olduğunda" olayından çağırabilirsiniz
dilerim işinize yarar

Private Sub Dagilim()



Dim Kalan, x, CtlDeger, Toplam As Integer

Dim MtnDizi, CtlAdi As String

Dim xDizi() As String

Kalan = 0

Toplam = 0

MtnDizi = ""



For x = 1 To 5

    Toplam = Toplam + Nz(Controls("P" & x), 0) 'P alanlarındaki değerleri Topla

    MtnDizi = MtnDizi & ";P" & x & Nz(Controls("P" & x), 0) 'diziye aktarabilmek için PAlanAdı+değeri

    Controls("R" & x) = 0 'Ralanlarının ilk değerini 0 yap

Next x



MtnDizi = Mid(MtnDizi, 2) 'diziye aktarılacak metindeki ilk ";" kaldır

Kalan = Toplam - 18

xDizi = Split(MtnDizi, ";") 'diziye aktar

'hy Dizi_Sırala_______________________________________Küçükten Büyüge

    First = LBound(xDizi)

    Last = UBound(xDizi)

    For i = First To Last - 1

        For j = i + 1 To Last

            If CInt(Mid(xDizi(i), 3)) > CInt(Mid(xDizi(j), 3)) Then

                Temp = xDizi(j)

                xDizi(j) = xDizi(i)

                xDizi(i) = Temp

            End If

        Next j

    Next i



'hy Dizi_Sırala_______________________________________Bitti

If Kalan < 1 Then Exit Sub

Do While Kalan > 0 'kalan >0 olduğu sürece 1er 1er dağıtmak için

        For i = UBound(xDizi) To 0 Step -1 '

            CtlAdi = Mid(xDizi(i), 2, 1) 'hangi alan P1 mi p2 mi......

            CtlDeger = Mid(xDizi(i), 3) 'dizi değeri

            If Kalan = 0 Then Exit For

            If CtlDeger > 1 Then 'Px değeri 1 den büyükse

                Controls("R" & CtlAdi).Value = Nz(Controls("R" & CtlAdi).Value) + 1 'Rx'e 1 ekle

                Kalan = Kalan - 1 'kalanı azalt

            End If

            If CtlDeger = 1 And Nz(Controls("R" & CtlAdi).Value) = 0 Then 'Px=1 ve Rx=0 ise Rx'e 1 ekle

                Controls("R" & CtlAdi).Value = Nz(Controls("R" & CtlAdi).Value) + 1

                Kalan = Kalan - 1

            End If

            

        Next i

Loop

End Sub