D'Hondt sistemi için KTF yapılabilir mi?

[Muhammet Okumuş]

Veysel Bey, #DEĞER hatası veriyor.

 

[veyselemre]

Veysel Bey, #DEĞER hatası veriyor.

 

[Muhammet Okumuş]

Sn. Veysel Bey, cevabınız için çok teşekkür ederim. Cevabınız çözüme ulaştırdı. Aradığım cevap buydu.

 

[veyselemre]

Aşağıdaki kodlamada, eşit oyların bulunması durumunda, eşit oy alanlar arasında rastgele dağıtım sağlanmıştır. Bütün partilere eşit oy verilerek denenebilir.

Function dHondt(oylar, mvSayisi)
    Dim yeniOylar, say&, i&, ii&, sonuclar
    yeniOylar = Application.Transpose(oylar.Value)
    say = UBound(yeniOylar)
    ReDim Preserve yeniOylar(1 To say, 1 To 4)

    Randomize Timer
   
    For i = 1 To say
        yeniOylar(i, 2) = Rnd()
        yeniOylar(i, 3) = i
        yeniOylar(i, 4) = 0
    Next i

    For i = 1 To say - 1
        For ii = i + 1 To say
            If yeniOylar(i, 2) > yeniOylar(ii, 2) Then
                ara = yeniOylar(ii, 1)
                yeniOylar(ii, 1) = yeniOylar(i, 1)
                yeniOylar(i, 1) = ara
                ara = yeniOylar(ii, 2)
                yeniOylar(ii, 2) = yeniOylar(i, 2)
                yeniOylar(i, 2) = ara
                ara = yeniOylar(ii, 3)
                yeniOylar(ii, 3) = yeniOylar(i, 3)
                yeniOylar(i, 3) = ara
            End If
        Next ii
    Next i

    ReDim sonuclar(1 To 1, 1 To say)

    For i = 1 To mvSayisi.Value
        mx = 0
        sira = 0
        For ii = 1 To say
            bolum = (yeniOylar(ii, 1) / (yeniOylar(ii, 4) + 1))
            If bolum > mx Then
                mx = bolum
                sira = ii
            End If
        Next ii
        yeniOylar(sira, 4) = yeniOylar(sira, 4) + 1
    Next i
    For i = 1 To say
        sonuclar(1, yeniOylar(i, 3)) = yeniOylar(i, 4)
    Next i

    dHondt = sonuclar
End Function

 

[Muhammet Okumuş]

Rastgele değil de eşitlik sağlanabilir mi? Örneğin 10 MV için 4 parti eşit oy alsa hepsine 3 verilebilir mi? MV sayısı 12 ye çıkacak.

 

[veyselemre]

Rastgele değil de eşitlik sağlanabilir mi? Örneğin 10 MV için 4 parti eşit oy alsa hepsine 3 verilebilir mi? MV sayısı 12 ye çıkacak.

Test edin.

Function dHondt(oylar, mvSayisi)

    oylar = Application.Index(oylar.Value, 0)

    ReDim sonuclar(1 To 1, 1 To UBound(oylar))

    For i = 1 To mvSayisi.Value
        mx = 0
        sira = 0

        For ii = 1 To UBound(oylar)
            bolum = (oylar(ii) / (sonuclar(1, ii) + 1))
            If bolum > mx Then
                mx = bolum
                sira = ii
            End If
        Next ii
        If i <> mvSayisi.Value Then
            sonuclar(1, sira) = Val(sonuclar(1, sira)) + 1
        Else
            For ii = 1 To UBound(oylar)
                bolum = (oylar(ii) / (sonuclar(1, ii) + 1))
                If bolum = mx Then
                    sonuclar(1, ii) = Val(sonuclar(1, ii)) + 1
                End If
            Next ii

        End If
    Next i
    dHondt = sonuclar

End Function

 

[Muhammet Okumuş]

Evet bu daha adil oldu. Sn. veyselemre çok teşekkür ederim. Yardımcı hücrelerden kurtulmuş olduk.

 

[Muhammet Okumuş]

Veysel Bey, veriler satırlarda olunca hesaplama yapmıyor sanırım!

 

[veyselemre]

Veysel Bey, veriler satırlarda olunca hesaplama yapmıyor sanırım!

Function dHondt(oylar, mvSayisi)

    If oylar.Columns.Count > 1 Then
        oylar = Application.Index(oylar.Value, 0)
        sutunlar = False
    Else
        sutunlar = True
        oylar = Application.Index(Application.Transpose(oylar.Value), 0)
    End If

    ReDim sonuclar(1 To 1, 1 To UBound(oylar))

    For i = 1 To mvSayisi.Value
        mx = 0
        sira = 0

        For ii = 1 To UBound(oylar)
            bolum = (oylar(ii) / (sonuclar(1, ii) + 1))
            If bolum > mx Then
                mx = bolum
                sira = ii
            End If
        Next ii
        If i <> mvSayisi.Value Then
            sonuclar(1, sira) = Val(sonuclar(1, sira)) + 1
        Else
            For ii = 1 To UBound(oylar)
                bolum = (oylar(ii) / (sonuclar(1, ii) + 1))
                If bolum = mx Then
                    sonuclar(1, ii) = Val(sonuclar(1, ii)) + 1
                End If
            Next ii

        End If
    Next i

    If sutunlar Then sonuclar = Application.Transpose(sonuclar)
    dHondt = sonuclar

End Function

 

[Muhammet Okumuş]

Çok teşekkür ederim Sn. veyselemre. Allah razı olsun.

 

[Muhammet Okumuş]

Veysel Bey, kotuk sayısını hücreden alınca hesaplıyor ama sayısal değer girince hesaplamıyor.
=dHondt(K$6:K$21;48) burda #DEĞER hatası veriyor.
A2 hücresine 48 yazınca =dHondt(K$6:K$21;A$2) bu formülde hata vermiyor. Bu değeri ister hücreye isterse formüle yazarak hesaplatabilir miyiz?

 

[veyselemre]

2 yerde geçen

mvSayisi.Value

ifadesini

mvSayisi

ile değiştirin.

 

[Muhammet Okumuş]

Teşekkürler Veysel Bey.

 

[gy121]

Teşekkürler Veysel Bey.

@veyselemre ve @Muhammet Okumuş Hocam dosyayı yükleme imkanınız var mı? Saygılarımla

 

[Muhammet Okumuş]

https://drive.google.com/file/d/1y7V1RZVRnYtucUlDWuC_WcsDkBtVS8uV/view?usp=drivesdk

 

[gy121]

https://drive.google.com/file/d/1y7V1RZVRnYtucUlDWuC_WcsDkBtVS8uV/view?usp=drivesdk

Hocam erişim izni yok diyor. Buraya yükleyebilirseniz buradan indirebilirim.

 

[Muhammet Okumuş]

Burda var zaten. Aynı dosyayı yükledim ben.

 

[gy121]

Burda var zaten. Aynı dosyayı yükledim ben.

Teşekkürler hocam