Excelde bir sütuna yazılan değeri rastgele dağıtma.

[asdsxx]

Arkadaşlar bir sorum olacak. Okulda bir çalışma için; ...
Microsoft Excel de A1,B1,C1,D1,E1 hücrelerinde sabit sayılar var. Bu hücrelerde yazılan değerden büyük ve yarısından küçük olmayacak şekilde F2 sütununa yazılan sayıyı A2,B2,C2,D2,E2 sütunlarına rastgele bölerek F2 sütunundaki sayının toplamına eşit olacak şekilde farklı sayıları farklı satırlarda rastgele olacak şekilde yazdırabileceğim basit formül yada makro olabilir mi?
Yalnız F sütununda Aynı değerler var bu değerler her satırın sütununda aynı olmayacak. Toplamları F sütununa eşit olacak ama aynı değer başka satırda farklı rastgele olacak.
5. döngüden sonra aynı değerler aynı sütunlarda olabilir.

Örnek Dosyada olduğu gibi

Selamlar...

 

[Muzaffer Ali]

Merhaba.
Başla butonuna tıkladığınızda kodlar çalışacak ve istediğiniz işlem gerçekleşecektir.

 

[asdsxx]

Merhaba.
Başla butonuna tıkladığınızda kodlar çalışacak ve istediğiniz işlem gerçekleşecektir.

Muzaffer Bey çok teşekkürler. ellerine sağlık.
Aynı yöntemin 5 ölçekli olarak da yapabilirsek çok iyi olacak.
tekrar teşekkürler.

 

[asdsxx]

Merhaba.
Başla butonuna tıkladığınızda kodlar çalışacak ve istediğiniz işlem gerçekleşecektir.

Örnek dosyada her iki alternatif vardı. Ben 5 li üzerinden anlatmaya çalıştım ve yan tarafa da aynı anlatımı yazmadan yandaki işlemin 10 lu sütunu da olacak demiştim.
Sağ olasın 10 lu sütun olarak hazırlamışsınız. 5 li sütun olarak da olursa çok güzel olacak.

 

[wezyr]

@Muzaffer Ali üstadın affına sığınarak;

Private Sub btnBasla_Click2()
    Dim Bak As Long
    Dim Sutun As Integer
    Dim Tavan As Long
    Application.ScreenUpdating = False
    For Bak = 3 To Cells(Rows.Count, "F").End(xlUp).Row
        Tavan = Cells(Bak, "F")
        For Sutun = 1 To 5
            Cells(Bak, Sutun) = Int((Tavan - (Tavan / 2) + 1) * Rnd + (Tavan / 2))
        Next
Kontrol:
        If WorksheetFunction.Sum(Cells(Bak, 1).Resize(1, 5)) > Cells(Bak, "F") Then
            For Sutun = 1 To 5
                If (Cells(2, Sutun) / 2) < Cells(Bak, Sutun) Then Cells(Bak, Sutun) = Cells(Bak, Sutun) - 1
                If WorksheetFunction.Sum(Cells(Bak, 1).Resize(1, 5)) = Cells(Bak, "F") Then Exit For
            Next
        ElseIf WorksheetFunction.Sum(Cells(Bak, 1).Resize(1, 5)) < Cells(Bak, "F") Then
         
            For Sutun = 1 To 5
                If Cells(2, Sutun) > Cells(Bak, Sutun) Then Cells(Bak, Sutun) = Cells(Bak, Sutun) + 1
                If WorksheetFunction.Sum(Cells(Bak, 1).Resize(1, 5)) = Cells(Bak, "F") Then Exit For
            Next
        End If
        If WorksheetFunction.Sum(Cells(Bak, 1).Resize(1, 5)) <> Cells(Bak, "F") Then GoTo Kontrol
    Next
    Application.ScreenUpdating = True
    MsgBox "Bitti"
End Sub

yeni bir buton ekleyerek kodu ekleyebilirsiniz 5 sayısı istedğiniz sütunu temsil edeiyor F ise sonuç sütununu temsil ediyor kendinize göre kurgulayabilirsiniz. sanırım performans ödevi puan dağıtımı için kullanmayı planlıyorsunuz

 

[asdsxx]

@Muzaffer Ali üstadın affına sığınarak;

Private Sub btnBasla_Click2()
    Dim Bak As Long
    Dim Sutun As Integer
    Dim Tavan As Long
    Application.ScreenUpdating = False
    For Bak = 3 To Cells(Rows.Count, "F").End(xlUp).Row
        Tavan = Cells(Bak, "F")
        For Sutun = 1 To 5
            Cells(Bak, Sutun) = Int((Tavan - (Tavan / 2) + 1) * Rnd + (Tavan / 2))
        Next
Kontrol:
        If WorksheetFunction.Sum(Cells(Bak, 1).Resize(1, 5)) > Cells(Bak, "F") Then
            For Sutun = 1 To 5
                If (Cells(2, Sutun) / 2) < Cells(Bak, Sutun) Then Cells(Bak, Sutun) = Cells(Bak, Sutun) - 1
                If WorksheetFunction.Sum(Cells(Bak, 1).Resize(1, 5)) = Cells(Bak, "F") Then Exit For
            Next
        ElseIf WorksheetFunction.Sum(Cells(Bak, 1).Resize(1, 5)) < Cells(Bak, "F") Then
        
            For Sutun = 1 To 5
                If Cells(2, Sutun) > Cells(Bak, Sutun) Then Cells(Bak, Sutun) = Cells(Bak, Sutun) + 1
                If WorksheetFunction.Sum(Cells(Bak, 1).Resize(1, 5)) = Cells(Bak, "F") Then Exit For
            Next
        End If
        If WorksheetFunction.Sum(Cells(Bak, 1).Resize(1, 5)) <> Cells(Bak, "F") Then GoTo Kontrol
    Next
    Application.ScreenUpdating = True
    MsgBox "Bitti"
End Sub

yeni bir buton ekleyerek kodu ekleyebilirsiniz 5 sayısı istedğiniz sütunu temsil edeiyor F ise sonuç sütununu temsil ediyor kendinize göre kurgulayabilirsiniz. sanırım performans ödevi puan dağıtımı için kullanmayı planlıyorsunuz

Teşekkür ederim. evet performans ve proje değerlendirme ölçeği içindi.
Ellerinize sağlık.

 

[asdsxx]

@Muzaffer Ali üstadın affına sığınarak;

Private Sub btnBasla_Click2()
    Dim Bak As Long
    Dim Sutun As Integer
    Dim Tavan As Long
    Application.ScreenUpdating = False
    For Bak = 3 To Cells(Rows.Count, "F").End(xlUp).Row
        Tavan = Cells(Bak, "F")
        For Sutun = 1 To 5
            Cells(Bak, Sutun) = Int((Tavan - (Tavan / 2) + 1) * Rnd + (Tavan / 2))
        Next
Kontrol:
        If WorksheetFunction.Sum(Cells(Bak, 1).Resize(1, 5)) > Cells(Bak, "F") Then
            For Sutun = 1 To 5
                If (Cells(2, Sutun) / 2) < Cells(Bak, Sutun) Then Cells(Bak, Sutun) = Cells(Bak, Sutun) - 1
                If WorksheetFunction.Sum(Cells(Bak, 1).Resize(1, 5)) = Cells(Bak, "F") Then Exit For
            Next
        ElseIf WorksheetFunction.Sum(Cells(Bak, 1).Resize(1, 5)) < Cells(Bak, "F") Then
       
            For Sutun = 1 To 5
                If Cells(2, Sutun) > Cells(Bak, Sutun) Then Cells(Bak, Sutun) = Cells(Bak, Sutun) + 1
                If WorksheetFunction.Sum(Cells(Bak, 1).Resize(1, 5)) = Cells(Bak, "F") Then Exit For
            Next
        End If
        If WorksheetFunction.Sum(Cells(Bak, 1).Resize(1, 5)) <> Cells(Bak, "F") Then GoTo Kontrol
    Next
    Application.ScreenUpdating = True
    MsgBox "Bitti"
End Sub

yeni bir buton ekleyerek kodu ekleyebilirsiniz 5 sayısı istedğiniz sütunu temsil edeiyor F ise sonuç sütununu temsil ediyor kendinize göre kurgulayabilirsiniz. sanırım performans ödevi puan dağıtımı için kullanmayı planlıyorsunuz

Sayın Hocam Sizin yazdığınız kod çalıştı Hatta 7 li ölçeğe uyarladım o da çalıştı. ama ben bir taslak oluşturup satır ve sütun yerleri değişince çalışmadı. Örnek dosyada yardımcı olabilirmisiniz.
Selamlar.

 

[wezyr]

Private Sub btnBasla_Click1()
    Dim Bak As Long
    Dim Sutun As Integer
    Dim Tavan As Long
    Dim MinDeger As Long
    Dim MaxDeger As Long
    Dim Toplam As Long
    Dim HucreDeger As Long

    Const BaslangicSatiri As Long = 7
    Const BaslangicSutunu As Integer = 5 ' Sütun E
    Const HedefSutun As String = "L"     ' Sütun L (12)

    Application.ScreenUpdating = False

    For Bak = BaslangicSatiri To Cells(Rows.Count, HedefSutun).End(xlUp).Row
        Tavan = Cells(Bak, HedefSutun).Value

        ' Rastgele sayılar üretme
        For Sutun = 0 To 6 ' 7 sütun
            MaxDeger = Cells(6, BaslangicSutunu + Sutun).Value
            MinDeger = MaxDeger / 2
            Cells(Bak, BaslangicSutunu + Sutun).Value = Int((MaxDeger - MinDeger + 1) * Rnd + MinDeger)
        Next

Kontrol:
        Toplam = WorksheetFunction.Sum(Range(Cells(Bak, BaslangicSutunu), Cells(Bak, BaslangicSutunu + 6)))

        If Toplam > Tavan Then
            For Sutun = 0 To 6
                HucreDeger = Cells(Bak, BaslangicSutunu + Sutun).Value
                MinDeger = Cells(6, BaslangicSutunu + Sutun).Value / 2
                If HucreDeger > MinDeger Then
                    Cells(Bak, BaslangicSutunu + Sutun).Value = HucreDeger - 1
                End If
                Toplam = WorksheetFunction.Sum(Range(Cells(Bak, BaslangicSutunu), Cells(Bak, BaslangicSutunu + 6)))
                If Toplam = Tavan Then Exit For
            Next
        ElseIf Toplam < Tavan Then
            For Sutun = 0 To 6
                HucreDeger = Cells(Bak, BaslangicSutunu + Sutun).Value
                MaxDeger = Cells(6, BaslangicSutunu + Sutun).Value
                If HucreDeger < MaxDeger Then
                    Cells(Bak, BaslangicSutunu + Sutun).Value = HucreDeger + 1
                End If
                Toplam = WorksheetFunction.Sum(Range(Cells(Bak, BaslangicSutunu), Cells(Bak, BaslangicSutunu + 6)))
                If Toplam = Tavan Then Exit For
            Next
        End If

        If WorksheetFunction.Sum(Range(Cells(Bak, BaslangicSutunu), Cells(Bak, BaslangicSutunu + 6))) <> Tavan Then GoTo Kontrol
    Next

    Application.ScreenUpdating = True
    MsgBox "Bitti"
End Sub

fazla kurcalamamak lazım. Bu arada yaptığınız işlem ölçme mantığına göre yanlış. Öğrencilerin hakkına girebilirsiniz. Öğrencilere hak ettiğinden yüksek not verdiğinizi umut ederek paylaşıyorum. Ama yazlı ortalamasına göre veriyorsanız yorum yapamıyorum şahsi fikrimdir.

 

[asdsxx]

fazla kurcalamamak lazım. Bu arada yaptığınız işlem ölçme mantığına göre yanlış. Öğrencilerin hakkına girebilirsiniz. Öğrencilere hak ettiğinden yüksek not verdiğinizi umut ederek paylaşıyorum. Ama yazlı ortalamasına göre veriyorsanız yorum yapamıyorum şahsi fikrimdir.

Çok teşekkür ederim. Ellerinize sağlık.
Tavsiyeniz için; Projeler öğrenci ortalamasını yükseltmek için alıyor. Yazılılar ile bağlantılı değil. Ayrıca önemli olan toplam puan.