classement (excel, maths?)

[jeanjacques]

Bonjour,

Je bute sur un classement de colonnes difficile, je joins un fichier avec le départ et le souhait après le code.

Merci de votre aide

A+

 

[job75]

Re : classement (excel, maths?)

Bonsoir jeanjacques,

Nous n'utilisons pas le même critère.

Sans vouloir vous vexer le mien me paraît plus pertinent.

Avec le mien, votre classement manuel donne un minimum de 36.

Ma macro a donné au 2ème essai un minimum de 34.

Fichier joint.

A+

 

[job75]

Re : classement (excel, maths?)

Bonjour jeanjacques, le forum,

Dans ce fichier (2) voici un autre algorithme.

La macro recherche la colonne optimale permettant de classer le maximum d'une même valeur :

Sub Minimum()
Dim NbTirage&, mini&, h&, P As Range, t, test() As Boolean
Dim d As Object, dc&, tirage&, c As Range, nmax&, j%, n&, i&, k%, col%, memo
NbTirage = [N6] 'nombre de tirages
mini = 1000000
Application.ScreenUpdating = False
With [A1].CurrentRegion.Resize(, 5)
  .Copy [G1]
  h = .Rows.Count
End With
Set P = [G1].Resize(h, 5)
t = P 'tableau VBA
ReDim test(1 To h, 1 To 5) 'tableau VBA
'---liste des valeurs sans doublon---
Set d = CreateObject("Scripting.Dictionary")
For Each c In P
  d(c.Value) = ""
Next
dc = d.Count
Range("Q2:R" & Rows.Count) = "" 'RAZ
[Q2].Resize(dc) = Application.Transpose(d.keys)
[R2].Resize(dc) = "=RAND()" 'ALEA()
'---détermination du minimum---
For tirage = 1 To NbTirage
  [Q2].Resize(dc, 2).Sort [R2], Header:=xlNo 'tri aléatoire
  For Each c In [Q2].Resize(dc)
   '---recherche de la colonne optimale---
   nmax = 0
    For j = 1 To 5
      n = 0
      For i = 1 To h
        If Not test(i, j) Then
          For k = 1 To 5
            If t(i, k) = c Then n = n + 1
          Next k
        End If
      Next i
      If n > nmax Then nmax = n: col = j
    Next j
    '---permutations dans t, repérages dans test---
    For i = 1 To h
      If Not t(i, col) Then
        For k = 1 To 5
          If t(i, k) = c Then
            t(i, k) = t(i, col)
            t(i, col) = c
            test(i, col) = True
            Exit For
          End If
        Next k
      End If
    Next i
  Next c
  ReDim test(1 To h, 1 To 5) 'RAZ du repérage
  P = t
  If Round([M3]) < mini Then mini = Round([M3]): memo = P 'mémorisation
Next tirage
P = memo 'restitution
End Sub

Avec 1000 tirages on obtient assez facilement le minimum de 34.

Bonne journée.

 

[jeanjacques]

Re : classement (excel, maths?)

Bonjour,

C'est vrai que l'on ne compte pas de la même manière (je compte le nombre de nombres "dispersés" dans plusieurs colonnes)

J'ai réussi par un simple nb.si en M3 à faire tourner la macro qui cherche le minimum de nombres dispersés.

Je ne vois pas de changement avec cette nouvelle mouture? plus rapide? plus efficace?

ps: en quoi la modification du nombre d'aléa modifie-t-elle le résultat? faut-il mettre 15?

ps2: peut-elle mettre en rouge les erreurs dans le tableau résultat pour mieux voir?

Merci beaucoup et bonne journée.

Jean Jacques

 

[job75]

Re : classement (excel, maths?)

Re,

ps: en quoi la modification du nombre d'aléa modifie-t-elle le résultat? faut-il mettre 15?

Il n'y en a plus dans le fichier (2) du post #32, toutes les valeurs sont étudiées aléatoirement.

Et je viens de supprimer la colonne R (Nb) qui n'est plus utile.

A+

 

[job75]

Re : classement (excel, maths?)

Re,

ps2: peut-elle mettre en rouge les erreurs dans le tableau résultat pour mieux voir?

Pas de difficulté, il suffit de compléter la macro à la fin :

Sub Minimum()
Dim NbTirage&, mini&, h&, P As Range, t, test() As Boolean
Dim d As Object, dc&, tirage&, c As Range, nmax&, j%, n&, i&, k%, col%, memo
NbTirage = [N6] 'nombre de tirages
mini = 1000000
Application.ScreenUpdating = False
With [A1].CurrentRegion.Resize(, 5)
  .Copy [G1]
  h = .Rows.Count
End With
Set P = [G1].Resize(h, 5)
t = P 'tableau VBA
ReDim test(1 To h, 1 To 5) 'tableau VBA
'---liste des valeurs sans doublon et comptage---
Set d = CreateObject("Scripting.Dictionary")
For Each c In P
  d(c.Value) = d(c.Value) + 1
Next
dc = d.Count
Range("Q2:R" & Rows.Count) = "" 'RAZ
[Q2].Resize(dc) = Application.Transpose(d.keys)
[R2].Resize(dc) = "=RAND()" 'ALEA()
'---détermination du minimum---
For tirage = 1 To NbTirage
  [Q2].Resize(dc, 2).Sort [R2], Header:=xlNo 'tri aléatoire
  For Each c In [Q2].Resize(dc)
    '---recherche de la colonne optimale---
    nmax = 0
    For j = 1 To 5
      n = 0
      For i = 1 To h
        If Not test(i, j) Then
          For k = 1 To 5
            If t(i, k) = c Then n = n + 1
          Next k
        End If
      Next i
      If n > nmax Then nmax = n: col = j
    Next j
    '---permutations dans t, repérages dans test---
    For i = 1 To h
      If Not t(i, col) Then
        For k = 1 To 5
          If t(i, k) = c Then
            t(i, k) = t(i, col)
            t(i, col) = c
            test(i, col) = True
            Exit For
          End If
        Next k
      End If
  Next i, c
  ReDim test(1 To h, 1 To 5) 'RAZ du repérage
  P = t
  If Round([M3]) < mini Then mini = Round([M3]): memo = P 'mémorisation
Next tirage
P = memo 'restitution
'---coloration des valeurs dispersées---
For i = 1 To h
  For j = 1 To 5
    If Application.CountIf(P.Columns(j), P(i, j)) < d(P(i, j).Value) Then
      P(i, j).Font.ColorIndex = 3 'rouge
      P(i, j).Font.Bold = True 'gras
    End If
Next j, i
End Sub

Fichier (3).

A+

 

[jeanjacques]

Re : classement (excel, maths?)

Merci Job, c'est sympa.

pour info:

J'ai fait plusieurs tests (plusieurs nombres de lignes aussi) et paradoxalement c'est systématiquement la macro avant celle de l'optimisation de la meilleure colonne qui donne le meilleur résultat...donc je reste sur la précédente macro, mais avec autant d'aléa que de nombres (et non 12).

Quant à savoir pourquoi.....?

Merci beaucoup.

 

[job75]

Re : classement (excel, maths?)

Re,

Quant à savoir pourquoi.....?

Pas très difficile à comprendre : le fichier (1) du post #31 ne classe les valeurs que si leur nombre dans la colonne est égal à leur nombre dans le tableau.

Maintenant voici une version qui utilise en M3 votre critère avec la fonction VBA ValeursNonClassees :

Dim h&, d As Object, d1 As Object 'variables mémorisées pour accélérer la fonction

Function ValeursNonClassees(P As Range)
Dim c As Range, i&, j%
If Not IsArray(d) Then 'au tout début
  h = P.Rows.Count
  Set d = CreateObject("Scripting.Dictionary")
  Set d1 = CreateObject("Scripting.Dictionary")
  For Each c In P
    d(c.Value) = d(c.Value) + 1
  Next
End If
d1.RemoveAll 'RAZ
For i = 1 To h
  For j = 1 To 5
    If Application.CountIf(P.Columns(j), P(i, j)) < d(P(i, j).Value) _
      Then d1(P(i, j).Value) = "" 'valeurs sans doublon
Next j, i
ValeursNonClassees = d1.Count
End Function

Sub Minimum()
Dim NbTirage&, mini&, P As Range, t, test() As Boolean
Dim dc&, tirage&, c As Range, j%, n&, i&, k%, memo
NbTirage = [N6] 'nombre de tirages
mini = 1000000
Application.ScreenUpdating = False
With [A1].CurrentRegion.Resize(, 5)
  .Copy [G1]
  h = .Rows.Count
End With
Set P = [G1].Resize(h, 5)
t = P 'tableau VBA
ReDim test(1 To h, 1 To 5) 'tableau VBA
Set d = CreateObject("Scripting.Dictionary")
Set d1 = CreateObject("Scripting.Dictionary")
'---liste des valeurs sans doublon et comptage---
For Each c In P
  d(c.Value) = d(c.Value) + 1
Next
dc = d.Count
Range("Q2:S" & Rows.Count) = "" 'RAZ
[Q2].Resize(dc) = Application.Transpose(d.keys)
[R2].Resize(dc) = Application.Transpose(d.items)
[S2].Resize(dc) = "=RAND()" 'ALEA()
'---détermination du minimum---
For tirage = 1 To NbTirage
  [Q2].Resize(dc, 3).Sort [S2], Header:=xlNo 'tri aléatoire
  For Each c In [Q2].Resize(dc)
    '---comptage préalable---
    For j = 1 To 5
      n = 0
      For i = 1 To h
        If Not test(i, j) Then
          For k = 1 To 5
            If t(i, k) = c Then
              n = n + 1
              If n = c(1, 2) Then GoTo 1
              Exit For
            End If
          Next k
        End If
    Next i, j
    '---permutations dans t, repérages dans test---
1   If n = c(1, 2) Then
      For i = 1 To h
        If Not t(i, j) Then
          For k = 1 To 5
            If t(i, k) = c Then
              t(i, k) = t(i, j)
              t(i, j) = c
              test(i, j) = True
              Exit For
            End If
          Next k
        End If
      Next i
    End If
  Next c
  ReDim test(1 To h, 1 To 5) 'RAZ du repérage
  P = t
  If Round([M3]) < mini Then mini = Round([M3]): memo = P 'mémorisation
Next tirage
P = memo 'restitution
'---coloration des valeurs non classées---
For i = 1 To h
  For j = 1 To 5
    If Application.CountIf(P.Columns(j), P(i, j)) < d(P(i, j).Value) Then
      P(i, j).Font.ColorIndex = 3 'rouge
      P(i, j).Font.Bold = True 'gras
    End If
Next j, i
Set d = Nothing 'RAZ
End Sub

Fichier joint, on trouve le minimum de 5 sans difficulté avec 10 tirages.

A+

 

[job75]

Re : classement (excel, maths?)

Re,

Fichier (2) avec votre tableau de 30 lignes du post #17.

A+

 

[jeanjacques]

Re : classement (excel, maths?)

Re,

Merci pour cette version très rapide.

Je teste le fichier (le premier) avec un nombre variables de lignes. Je me demande si vous n'aviez pas raison sur le critère de tri.
En effet, ma dernière version en M3 compte le nombre de "rouges" dans la plage car, avant, un résultat faible en M3 pouvait donner beaucoup de rouges (si c'est 3 nombres (par ex) étaient très présents) comme un nombre plus grand en M3 (par ex 8) peut donner peu de rouges dans la plage ( si ces 8 nombres ne sont présents que 2 fois par ex) .....

3X7 = 21 alors que 8X2=16 ....

je vais voir....

Bonne soirée
Jean Jacques

 

[job75]

Re : classement (excel, maths?)

Re,

Alors maintenant vous voulez minimiser le nombre total de valeurs colorées.

Il suffit de modifier la fonction en M3 :

Function ToutesValeursNonClassees(P As Range)
Dim c As Range, i&, j%
If Not IsArray(d) Then 'au tout début
  h = P.Rows.Count
  Set d = CreateObject("Scripting.Dictionary")
  For Each c In P
    d(c.Value) = d(c.Value) + 1
  Next
End If
For i = 1 To h
  For j = 1 To 5
    If Application.CountIf(P.Columns(j), P(i, j)) < d(P(i, j).Value) _
      Then ToutesValeursNonClassees = ToutesValeursNonClassees + 1
Next j, i
End Function

Fichiers joints, c'est nettement plus long pour atteindre le minimum.

A+

 

[jeanjacques]

Re : classement (excel, maths?)

Bonjour Job, le forum,

J'ai eu une idée de formulation (autre façon de faire) qui semble (?) donner de bon résultats en alignement des nombres, avec ta macro "minimum", je t'en fais part, merci de ton commentaire si tu veux bien.

Bon vendredi.

 

[job75]

Re : classement (excel, maths?)

merci de ton commentaire si tu veux bien.

Bon vendredi.

Pour l'instant je me contente de survivre ce jeudi

On peut bien sûr se donner des critères divers et variés.

Pour celui-ci j'écrirais simplement en M3 :

=SOMME((FREQUENCE(G1:H20;G1:H20)=1)+(FREQUENCE(I1:J20;I1:J20)=1))

J'ai obtenu un minimum de 7 après quelques essais.

A+