Répartition selon la méthode de la plus forte moyenne

**Kaytilou** · 25/05/2021, 16h08

Bonjour à tous
Tout d'abord, j'espère que vous allez tous bien et que vous profitez des bons moments hors confinements. Il ne manque plus que le soleil :-)

J'ai créé un tableau excel avec quelques formules. Il s'agit de faire des pronostics sur les élections en mode « Répartition des sièges au scrutin proportionnel selon la méthode de la plus forte moyenne ». J'ai besoin de créer un code VBA pour calculer la répartition des sièges suivant le quotient électoral.

Nom : Capture.JPG
Affichages : 1163
Taille : 54,7 Ko

Nom : Capture.JPG
Affichages : 1163
Taille : 54,7 Ko

Le Quotient électoral est calculé de la manière suivante : nombre de suffrages exprimés / nombre de sièges. Soit Q. (H5)

Attribution des sièges
1. On divise par Q le nombre de voix obtenus par chaque liste. Soit liste des voix. (J4) => on répète le calcul sur chaque ligne de la colonne J
2. On attribue V/L sièges à chaque liste (avec arrondi à l'unité inférieure)

Ce système avec arrondi à l'unité inférieure laisse un certain nombre de sièges restants à attribuer H5-J3, dans l'exemple 2 sièges

Attribution des sièges restants
1. Pour chaque liste, on divise le nombre de suffrages exprimés par le nombre de sièges attribués à cette liste + 1. Cela donne une moyenne pour chaque liste.
2. On attribue un siège à la liste ayant la plus forte moyenne. En cas d'égalité, on l'attribue à la liste ayant le plus grand nombre de voix.
Et on répète les étapes jusqu'à épuisement des sièges.

J'ai bien testé des formules, mais il me faut autant de colonne (*3) que le nombre de sièges. C'est pour cela que je pense à un code VBA

Voilà, vous savez tout. A date, je n'ai aucune idée de comment faire

Je vous remercie pour votre aide et vous souhaite une agréable journée

**ARTURO83** · 26/05/2021, 08h14

Bonjour,

Ceci correspond-il à vos attentes?
Pièce jointe 598582

le code

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
Sub Repartition_Sieges_Conseillers()
    Dim i As Long
    Dim Nb_Sieges_Conseillers As Long, Total_Votants As Long, Total_Sieges As Long
    Dim Quotient_Electoral_Conseillers As Double
    Application.ScreenUpdating = False
    Nb_Sieges_Conseillers = Range("H5").Value
 
    'Formules nombre de votants
    Range("G8").FormulaR1C1 = "=SUM(R[-4]C:R[-1]C)"
    Total_Votants = Range("G8").Value
    Quotient_Electoral_Conseillers = Total_Votants / Nb_Sieges_Conseillers
 
    'Formules d'attribution des sièges
    Range("J4:J7").FormulaR1C1 = "=INT(RC7/R7C8)"
    Range("J4:J7").Value = Range("J4:J7").Value
    Range("J8").FormulaR1C1 = "=SUM(R[-4]C:R[-1]C)"
    Total_Sieges = Range("J8").Value
 
    Do While Range("J8") < Range("H5")
        'Recherche de la plus grande moyenne
        Range("L4:L7").FormulaR1C1 = "=IFERROR(RC7/(RC10+1),RC7/1)"
        'Formule d'attribution d'un siège supplémentaire à la liste obtenant la plus grande moyenne
        Range("M4:M7").FormulaR1C1 = "=IF(OR(AND(MAX(R4C12:R7C12)=RC[-1],COUNTIF(R4C12:R7C12,RC12)=1)," & Chr(10) & "AND(MAX(R4C12:R7C12)=RC[-1],COUNTIF(R4C12:R7C12,RC12)>1,MAX(R4C7:R7C7)=RC7)),1,0)"
        For i = 4 To 7
            If Cells(i, "M") = 1 Then
                Cells(i, "J") = Cells(i, "J") + Cells(i, "M")
                Exit For
            End If
        Next i
    Loop
    Range("L4:M7").ClearContents
End Sub

Le fichier
Pièce jointe 598583

Cdlt

**Kaytilou** · 26/05/2021, 10h19

Bonjour Arturo83
Je vous remercie, c'est exactement ce que je souhaitais.
Le seul hic que m'impose les futures élections et que je dois adapter ce modèle par circonscriptions / pays et par conséquent avoir 25 fois le même tableau dans un onglet de mon fichier (*4 onglets). Du coup, je pense qu'il est difficile d'adapter la macro à l'ensemble des circonscriptions (chaque tableau) à moins de dupliquer autant de fois le code par tableau.
Avez vous une idée ?
Je vous remercie pour votre aide et vous souhaite une agréable journée
Kaytilou

**ARTURO83** · 26/05/2021, 11h28

Le seul hic que m'impose les futures élections et que je dois adapter ce modèle par circonscriptions / pays et par conséquent avoir 25 fois le même tableau dans un onglet de mon fichier (*4 onglets). Du coup, je pense qu'il est difficile d'adapter la macro à l'ensemble des circonscriptions (chaque tableau) à moins de dupliquer autant de fois le code par tableau.

Tout dépend comment sera organisé votre fichier:
-Combien de circonscriptions? Combien de pays?
-Une feuille par tableau ou tout à la suite?

Avec un tableau par feuille c'est le plus simple, il suffira de modifier légèrement la macro.

**Kaytilou** · 26/05/2021, 11h50

Cela dépend en fonction des pays, mais grosso modo, 5 onglets avec au maximum 30 circonscriptions avec des tableaux à la suite les uns des autres.
Voici ce que j'ai construit comme tableau (avec des formules). J'ai groupé aussi les colonnes
Merci pour tout

Envoyé par ARTURO83

Tout dépend comment sera organisé votre fichier:
-Combien de circonscriptions? Combien de pays?
-Une feuille par tableau ou tout à la suite?

Avec un tableau par feuille c'est le plus simple, il suffira de modifier légèrement la macro.

**ARTURO83** · 27/05/2021, 08h23

Bonjour,

Voilà, faites une multitude d'essais pour voir si tout est correct. Cliquez sur le bouton "Répartitions en haut à gauche de chaque feuille.
Le fichier:
Pièce jointe 598657

Le code:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
    Dim f1 As Worksheet, f2 As Worksheet
    Dim i As Long, j As Long
    Dim Col_Rep As Long, Col_Moy As Long
 
Sub Afrique_et_MO()
    Application.ScreenUpdating = False
    Set f1 = Sheets("Afrique et MO")
    Set f2 = Sheets("Calculs")
    f2.Select
    'répartitions des conseillers
    For i = 4 To 251 Step 13
        If f1.Range("H" & i + 10).Value <> 0 Then
            f1.Range("J" & i & ":L" & i + 9 & ", N" & i & ":O" & i + 9 & ", Q" & i & ":R" & i + 9 & ", T" & i & ":U" & i + 9 & ", W" & i & ":X" & i + 9 & ", Z" & i & ":AA" & i + 9 & ",AC" & i & ":AD" & i + 9 & ", AF" & i & ":AG" & i + 9 & ", AI" & i & ":AJ" & i + 9).ClearContents
            f2.Range("H5").Value = f1.Range("I" & i + 1).Value 'Nombre de sièges
            f2.Range("G4:G13").Value = f1.Range("H" & i & ":H" & i + 9).Value
            Col_Rep = 10
            Col_Moy = 11
            Repartition_Sieges
        End If
    Next i
 
    'répartitions des délégués
    For i = 4 To 251 Step 13
        If f1.Range("H" & i + 10).Value <> 0 Then
            f1.Range("AN" & i & ":AP" & i + 9 & ", AR" & i & ":AS" & i + 9 & ", AU" & i & ":AV" & i + 9 & ", AX" & i & ":AY" & i + 9 & ", BA" & i & ":BB" & i + 9 & ", BD" & i & ":BE" & i + 9 & ",BG" & i & ":BH" & i + 9 & ", BJ" & i & ":BK" & i + 9 & ", BM" & i & ":BN" & i + 9).ClearContents
            f2.Range("H5").Value = f1.Range("AM" & i + 1).Value 'Nombre de sièges
            f2.Range("G4:G13").Value = f1.Range("H" & i & ":H" & i + 9).Value
            Col_Rep = 40
            Col_Moy = 41
            Repartition_Sieges
        End If
    Next i
    f1.Select
End Sub
 
Sub Amérique_du_Sud()
    Application.ScreenUpdating = False
    Set f1 = Sheets("Amérique du Sud")
    Set f2 = Sheets("Calculs")
    f2.Select
    'répartitions des conseillers
    For i = 4 To 251 Step 13
        If f1.Range("H" & i + 10).Value <> 0 Then
            f1.Range("J" & i & ":L" & i + 9 & ", N" & i & ":O" & i + 9 & ", Q" & i & ":R" & i + 9 & ", T" & i & ":U" & i + 9 & ", W" & i & ":X" & i + 9 & ", Z" & i & ":AA" & i + 9 & ",AC" & i & ":AD" & i + 9 & ", AF" & i & ":AG" & i + 9 & ", AI" & i & ":AJ" & i + 9).ClearContents
            f2.Range("H5").Value = f1.Range("I" & i + 1).Value 'Nombre de sièges
            f2.Range("G4:G13").Value = f1.Range("H" & i & ":H" & i + 9).Value
            Col_Rep = 10
            Col_Moy = 11
            Repartition_Sieges
        End If
    Next i
 
    'répartitions des délégués
    For i = 4 To 251 Step 13
        If f1.Range("H" & i + 10).Value <> 0 Then
            f1.Range("AN" & i & ":AP" & i + 9 & ", AR" & i & ":AS" & i + 9 & ", AU" & i & ":AV" & i + 9 & ", AX" & i & ":AY" & i + 9 & ", BA" & i & ":BB" & i + 9 & ", BD" & i & ":BE" & i + 9 & ",BG" & i & ":BH" & i + 9 & ", BJ" & i & ":BK" & i + 9 & ", BM" & i & ":BN" & i + 9).ClearContents
            f2.Range("H5").Value = f1.Range("AM" & i + 1).Value 'Nombre de sièges
            f2.Range("G4:G13").Value = f1.Range("H" & i & ":H" & i + 9).Value
            Col_Rep = 40
            Col_Moy = 41
            Repartition_Sieges
        End If
    Next i
    f1.Select
End Sub
 
Sub Amérique_du_Nord()
    Application.ScreenUpdating = False
    Set f1 = Sheets("Amérique du Nord")
    Set f2 = Sheets("Calculs")
    f2.Select
    'répartitions des conseillers
    For i = 4 To 251 Step 13
        If f1.Range("H" & i + 10).Value <> 0 Then
            f1.Range("J" & i & ":L" & i + 9 & ", N" & i & ":O" & i + 9 & ", Q" & i & ":R" & i + 9 & ", T" & i & ":U" & i + 9 & ", W" & i & ":X" & i + 9 & ", Z" & i & ":AA" & i + 9 & ",AC" & i & ":AD" & i + 9 & ", AF" & i & ":AG" & i + 9 & ", AI" & i & ":AJ" & i + 9).ClearContents
            f2.Range("H5").Value = f1.Range("I" & i + 1).Value 'Nombre de sièges
            f2.Range("G4:G13").Value = f1.Range("H" & i & ":H" & i + 9).Value
            Col_Rep = 10
            Col_Moy = 11
            Repartition_Sieges
        End If
    Next i
 
    'répartitions des délégués
    For i = 4 To 251 Step 13
        If f1.Range("H" & i + 10).Value <> 0 Then
            f1.Range("AN" & i & ":AP" & i + 9 & ", AR" & i & ":AS" & i + 9 & ", AU" & i & ":AV" & i + 9 & ", AX" & i & ":AY" & i + 9 & ", BA" & i & ":BB" & i + 9 & ", BD" & i & ":BE" & i + 9 & ",BG" & i & ":BH" & i + 9 & ", BJ" & i & ":BK" & i + 9 & ", BM" & i & ":BN" & i + 9).ClearContents
            f2.Range("H5").Value = f1.Range("AM" & i + 1).Value 'Nombre de sièges
            f2.Range("G4:G13").Value = f1.Range("H" & i & ":H" & i + 9).Value
            Col_Rep = 40
            Col_Moy = 41
            Repartition_Sieges
        End If
    Next i
    f1.Select
End Sub
 
Sub Asie_et_Océanie()
    Application.ScreenUpdating = False
    Set f1 = Sheets("Asie et Océanie")
    Set f2 = Sheets("Calculs")
    f2.Select
    'répartitions des conseillers
    For i = 4 To 251 Step 13
        If f1.Range("H" & i + 10).Value <> 0 Then
            f1.Range("J" & i & ":L" & i + 9 & ", N" & i & ":O" & i + 9 & ", Q" & i & ":R" & i + 9 & ", T" & i & ":U" & i + 9 & ", W" & i & ":X" & i + 9 & ", Z" & i & ":AA" & i + 9 & ",AC" & i & ":AD" & i + 9 & ", AF" & i & ":AG" & i + 9 & ", AI" & i & ":AJ" & i + 9).ClearContents
            f2.Range("H5").Value = f1.Range("I" & i + 1).Value 'Nombre de sièges
            f2.Range("G4:G13").Value = f1.Range("H" & i & ":H" & i + 9).Value
            Col_Rep = 10
            Col_Moy = 11
            Repartition_Sieges
        End If
    Next i
 
    'répartitions des délégués
    For i = 4 To 251 Step 13
        If f1.Range("H" & i + 10).Value <> 0 Then
            f1.Range("AN" & i & ":AP" & i + 9 & ", AR" & i & ":AS" & i + 9 & ", AU" & i & ":AV" & i + 9 & ", AX" & i & ":AY" & i + 9 & ", BA" & i & ":BB" & i + 9 & ", BD" & i & ":BE" & i + 9 & ",BG" & i & ":BH" & i + 9 & ", BJ" & i & ":BK" & i + 9 & ", BM" & i & ":BN" & i + 9).ClearContents
            f2.Range("H5").Value = f1.Range("AM" & i + 1).Value 'Nombre de sièges
            f2.Range("G4:G13").Value = f1.Range("H" & i & ":H" & i + 9).Value
            Col_Rep = 40
            Col_Moy = 41
            Repartition_Sieges
        End If
    Next i
    f1.Select
End Sub
 
Sub Europe()
    Application.ScreenUpdating = False
    Set f1 = Sheets("Europe")
    Set f2 = Sheets("Calculs")
    f2.Select
    'répartitions des conseillers
    For i = 4 To 251 Step 13
        If f1.Range("H" & i + 10).Value <> 0 Then
            f1.Range("J" & i & ":L" & i + 9 & ", N" & i & ":O" & i + 9 & ", Q" & i & ":R" & i + 9 & ", T" & i & ":U" & i + 9 & ", W" & i & ":X" & i + 9 & ", Z" & i & ":AA" & i + 9 & ",AC" & i & ":AD" & i + 9 & ", AF" & i & ":AG" & i + 9 & ", AI" & i & ":AJ" & i + 9).ClearContents
            f2.Range("H5").Value = f1.Range("I" & i + 1).Value 'Nombre de sièges
            f2.Range("G4:G13").Value = f1.Range("H" & i & ":H" & i + 9).Value
            Col_Rep = 10
            Col_Moy = 11
            Repartition_Sieges
        End If
    Next i
 
    'répartitions des délégués
    For i = 4 To 251 Step 13
        If f1.Range("H" & i + 10).Value <> 0 Then
            f1.Range("AN" & i & ":AP" & i + 9 & ", AR" & i & ":AS" & i + 9 & ", AU" & i & ":AV" & i + 9 & ", AX" & i & ":AY" & i + 9 & ", BA" & i & ":BB" & i + 9 & ", BD" & i & ":BE" & i + 9 & ",BG" & i & ":BH" & i + 9 & ", BJ" & i & ":BK" & i + 9 & ", BM" & i & ":BN" & i + 9).ClearContents
            f2.Range("H5").Value = f1.Range("AM" & i + 1).Value 'Nombre de sièges
            f2.Range("G4:G13").Value = f1.Range("H" & i & ":H" & i + 9).Value
            Col_Rep = 40
            Col_Moy = 41
            Repartition_Sieges
        End If
    Next i
    f1.Select
End Sub
 
Sub Repartition_Sieges()
    Dim Nb_Sieges As Long, Total_Votants As Long, Total_Sieges As Long
    Dim Quotient_Electoral As Double
    Application.ScreenUpdating = False
    Nb_Sieges = f2.Range("H5").Value
    'Formules nombre de votants
    f2.Range("G14").FormulaR1C1 = "=SUM(R[-10]C:R[-1]C)"
    Total_Votants = f2.Range("G14").Value
    Quotient_Electoral = Total_Votants / Nb_Sieges
    f2.Range("H7") = Quotient_Electoral
    'Formules d'attribution des sièges
    f2.Range("J4:J13").FormulaR1C1 = "=INT(RC7/R7C8)"
    f2.Range("J4:J13").Value = Range("J4:J13").Value
    f2.Range("J14").FormulaR1C1 = "=SUM(R[-10]C:R[-1]C)"
    Total_Sieges = f2.Range("J14").Value
 
   '******************************************************************
    'Recherche de la plus grande moyenne
    f2.Range("L4:L13").FormulaR1C1 = "=IFERROR(RC7/(RC10+1),0)" '"=IFERROR(RC7/(RC10+1),RC7/1)"
    f2.Range("K4:K13").FormulaR1C1 = "=IF(COUNTIF(R4C12:R13C12,RC[1])>1,RC[-4],0)"
    'Formule d'attribution d'un siège supplémentaire à la liste obtenant la plus grande moyenne
    f2.Range("M4:M13").FormulaR1C1 = "=IF(OR(AND(MAX(R4C12:R13C12)=RC[-1],COUNTIF(R4C12:R13C12,RC12)=1)," & Chr(10) & "AND(MAX(R4C12:R13C12)=RC[-1],COUNTIF(R4C12:R13C12,RC12)>1,MAX(R4C11:R13C11)=RC11)),1,0)"
    Range(f1.Cells(i, Col_Rep), f1.Cells(i + 9, Col_Rep)).Value = f2.Range("J4:J13").Value
    Col_Rep = Col_Rep + 2
 
    Do While f2.Range("J14").Value < f2.Range("H5").Value
        For j = 4 To 13
            If f2.Cells(j, "M") = 1 Then
                f2.Cells(j, "J") = f2.Cells(j, "J") + Cells(j, "M")
                Range(f1.Cells(i, Col_Moy), f1.Cells(i + 9, Col_Moy)).Value = f2.Range("L4:L13").Value
                Range(f1.Cells(i, Col_Rep), f1.Cells(i + 9, Col_Rep)).Value = f2.Range("M4:M13").Value
                Col_Moy = Col_Moy + 3
                Col_Rep = Col_Rep + 3
                Exit For
            End If
        Next j
    Loop
    f2.Range("K4:M13").ClearContents
End Sub

Cdlt

Répartition selon la méthode de la plus forte moyenne

Macros et VBA Excel

Discussions similaires

Partager

Partager