Microsoft 365 Multiplication chiffres pairs/impairs

Patron28 · 15 Décembre 2020

Bonjour

Dans le fichier excel en pièce jointe, j'aimerai sur base d'un tableau de 10 chiffres ( pairs/impairs colonne C ), trouver

toutes les combinaisons des chiffres pairs/pairs, impairs/impairs et pairs/impairs sans doublons.

Exemples comme dans le fichiers.

Dans le tableau colonne C le nombre de chiffre pairs et Impairs peut varier. un petit bouton pour lancer la macro serait intéressant.

Je dois me lancer dans une macro sans doute mais je bloque.

Merci pour votre aide

Patron.

sylvanu · 15 Décembre 2020

Salut Patron,
Un essai en PJ avec :

VB:

Sub Tri()
Dim tablo(), T(), N%, DL%, N1%, N2%, N3%, P1%, P2%
Application.ScreenUpdating = False
Range("E4:L1000").ClearContents                                     ' On efface le tableau
DL = Range("C65500").End(xlUp).Row                                  ' DL dernière ligne
tablo = Range("C4:C" & DL)                                          ' Transfert dans array ( plus rapide )
N = (UBound(tablo) ^ 2 - UBound(tablo)) / 2                         ' Taille tableau résultat : (x²-x)/2
ReDim T(N, 1)
Ind = 0                                                             ' Ind : Indice dans secons tableau
For i = 1 To UBound(tablo)                                          ' On remplit le 2eme tableau avec...

sylvanu · 15 Décembre 2020

Salut Patron,
Un essai en PJ avec :

VB:

Sub Tri()
Dim tablo(), T(), N%, DL%, N1%, N2%, N3%, P1%, P2%
Application.ScreenUpdating = False
Range("E4:L1000").ClearContents                                     ' On efface le tableau
DL = Range("C65500").End(xlUp).Row                                  ' DL dernière ligne
tablo = Range("C4:C" & DL)                                          ' Transfert dans array ( plus rapide )
N = (UBound(tablo) ^ 2 - UBound(tablo)) / 2                         ' Taille tableau résultat : (x²-x)/2
ReDim T(N, 1)
Ind = 0                                                             ' Ind : Indice dans secons tableau
For i = 1 To UBound(tablo)                                          ' On remplit le 2eme tableau avec
    For j = i + 1 To UBound(tablo)                                  ' toutes les combinaisons sans doublons
        T(Ind, 0) = tablo(i, 1): T(Ind, 1) = tablo(j, 1)
        Ind = Ind + 1
    Next j
Next i
N1 = 4: N2 = 4: N3 = 4                                              ' Indice écriture dans les 3 tableaux sorties
For i = 0 To UBound(T)                                              ' Pour toutes les combinaisons
    If T(i, 0) = Application.Even(T(i, 0)) Then P1 = 0 Else P1 = 1  ' Calcul parité nombre 1
    If T(i, 1) = Application.Even(T(i, 1)) Then P2 = 0 Else P2 = 1  ' Calcul parité nombre 2
    If P1 = 0 And P2 = 0 Then                                       ' Si Pair/Pair premier tableau
        Cells(N1, "E") = T(i, 0): Cells(N1, "F") = T(i, 1)
        N1 = N1 + 1
    ElseIf P1 = 1 And P2 = 1 Then                                   ' Si Impair/Impair 2eme tableau
        Cells(N2, "H") = T(i, 0): Cells(N2, "I") = T(i, 1)
        N2 = N2 + 1
    ElseIf P1 = 1 And P2 = 0 Then                                   ' Si Impair/Pair 3eme tableau inversé
        Cells(N3, "L") = T(i, 0): Cells(N3, "K") = T(i, 1)
        N3 = N3 + 1
    Else
        Cells(N3, "K") = T(i, 0): Cells(N3, "L") = T(i, 1)          ' Sinon 3eme tableau normal
        N3 = N3 + 1
   End If
Next i
End Sub

Patron28 · 15 Décembre 2020

Bonjour Sylvanu

Merci pour ta réponse, cela me va très bien.

Merci pour le temps passé dessus.

Bien à toi

Patron

job75 · 15 Décembre 2020

Bonsoir Patron28, sylvanu,

La méthode utilisée par sylvanu est très bonne mais elle pèche sur un point : les résultats sont entrés dans les cellules un par un, ce qui prendra beaucoup de temps si le nombre de combinaisons est grand.

Cette macro n'a pas cet inconvénient car elle utilise jusqu'au bout des tableaux VBA :

VB:

Sub Combinaisons()
Dim tablo, resu1(), resu2(), resu3(), ub&, i&, j&, test As Byte, n1&, n2&, n3&
tablo = [OFFSET(C4,,,COUNT(C:C))]
If IsArray(tablo) Then 'sécurité
    ReDim resu1(1 To Rows.Count, 1 To 2)
    ReDim resu2(1 To Rows.Count, 1 To 2)
    ReDim resu3(1 To Rows.Count, 1 To 2)
    ub = UBound(tablo)
    For i = 1 To ub - 1
        test = tablo(i, 1) Mod 2 'parité 1 ou 0
        For j = i + 1 To ub
            Select Case test + (tablo(j, 1) Mod 2)
                Case 0: n1 = n1 + 1: resu1(n1, 1) = tablo(i, 1): resu1(n1, 2) = tablo(j, 1)
                Case 2: n2 = n2 + 1: resu2(n2, 1) = tablo(i, 1): resu2(n2, 2) = tablo(j, 1)
                Case 1: n3 = n3 + 1: resu3(n3, 1) = tablo(IIf(test, j, i), 1): resu3(n3, 2) = tablo(IIf(test, i, j), 1)
            End Select
    Next j, i
End If
'---restitutions---
Application.ScreenUpdating = False
With ActiveSheet
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    .Range("E4:L" & .Rows.Count).ClearContents 'RAZ
    If n1 Then .[E4].Resize(n1, 2) = resu1
    If n2 Then .[H4].Resize(n2, 2) = resu2
    If n3 Then .[K4].Resize(n3, 2) = resu3
    With .UsedRange: End With 'actualise la barre de défilement verticale
End With
End Sub

Notez également dans le fichier joint que les bordures sont appliquées par MFC.

A+

job75 · 15 Décembre 2020

Pour tester j'ai simplement rempli la plage C4:C203 avec les nombres entiers de 1 à 200.

La macro du post #2 s'exécute chez moi en 17 secondes, celle du post #4 en 0,06 seconde, c'est immédiat.

R@chid · 16 Décembre 2020

Bonsoir @ tous,

job75 à dit:
Pour tester j'ai simplement rempli la plage C4:C203 avec les nombres entiers de 1 à 200.
La macro du post #2 s'exécute chez moi en 17 secondes, celle du post #4 en 0,06 seconde, c'est immédiat.

Je viens de tester les deux codes, le tien et celui de sylvanu avec les nombres entiers de 1 à 200
Sylvanu : 3 secondes
Job75 : en un clin d'œil

Processeur Intel(R) Core(TM) i5-3470 CPU @ 3.20GHz 3.20 GHz
Mémoire RAM installée 8,00 Go (7,89 Go utilisable)
Type du système Système d’exploitation 64 bits, processeur x64

Édition Windows 10 Professionnel
Version 20H2
Version du système d’exploitation 19042.685
Expérience Windows Feature Experience Pack 120.2212.551.0

Excel pour Microsoft 365, Version 2011 (build 13426.20332)

Je ne sais pas pourquoi ça appris 17 secondes chez toi ?

Le VBA c'est cool, il faut que je m'y mette.

Cordialement

sylvanu · 16 Décembre 2020

Bonjour Patron, Job, R@chid,
On peut encore un peu optimiser en utilisant une seule matrice de sortie, ce qui simplifie le code et accélère un chouia :

VB:

Sub Tri()
Dim tablo(), T(), i%, j%, DL%, N1%, N2%, N3%, Parité$
Application.ScreenUpdating = False
Range("E4:L65535").ClearContents                                     ' On efface le tableau
DL = Range("C65500").End(xlUp).Row                                  ' DL dernière ligne
tablo = Range("C4:C" & DL)                                          ' Transfert dans array ( plus rapide )
ReDim T((DL ^ 2 - DL) / 2, 7)                                       ' Taille tableau résultat : (x²-x)/2
N1 = 0: N2 = 0: N3 = 0
For i = 1 To UBound(tablo)                                          ' On remplit le 2eme tableau avec
    For j = i + 1 To UBound(tablo)                                  ' toutes les combinaisons sans doublons
        Parité = (tablo(i, 1) Mod 2) & (tablo(j, 1) Mod 2)          ' Calcul Pair/Impair
        Select Case Parité
            Case "00"                                               ' Pair Pair
                T(N1, 0) = tablo(i, 1): T(N1, 1) = tablo(j, 1): N1 = N1 + 1
            Case "11"                                               ' Impair Impair
                T(N2, 3) = tablo(i, 1): T(N2, 4) = tablo(j, 1): N2 = N2 + 1
            Case "10"                                               ' Pair Impair
                T(N3, 6) = tablo(j, 1): T(N3, 7) = tablo(i, 1): N3 = N3 + 1
            Case Else                                               ' Impair Pair
                T(N3, 6) = tablo(i, 1): T(N3, 7) = tablo(j, 1): N3 = N3 + 1
        End Select
    Next j
Next i
Range("$E$4").Resize(Application.Max(N1, N2, N3), 8) = T            ' Transfert matrice
Sheets("Feuil1").UsedRange                                          ' Redimensionne ascenceur
End Sub

job75 · 16 Décembre 2020

Bonjour R@chid, sylvanu, le forum,

R@chid à dit:
]e ne sais pas pourquoi ça appris 17 secondes chez toi ?

Mon ordi est moins rapide que le tien en effet :

Processeur Intel(R) Core(TM) i7-8565 CPU @ 1.80GHz 1.99 GHz
Mémoire RAM installée 8,00 Go (7,89 Go utilisable)
Type du système Système d’exploitation 64 bits, processeur x64

Édition Windows 10 Famille
Version 2004
Version du système d’exploitation 19041.685
Expérience Windows Feature Experience Pack 120.2212.551.0

Excel 2019, Version 2011 (build 13426.20308) 64 bits

A+

job75 · 16 Décembre 2020

@sylvanu non ta dernière macro n'est pas plus rapide.

J'ai testé avec les nombres de 1 à 1000 dans C4:C1003 :

- macro du post #4 => 0,87 seconde

- macro du post #7 => 1,46 seconde, bien sur j'ai remplacé les % par &.

sylvanu · 16 Décembre 2020

@job,
Sous XL2007, évidemment à iso périmètre avec 200 nombres, 20 essai consécutifs j'obtiens sur mon vieux I5-2300 2.8G :

	min	moyenne	max
Job	266 ms	281 ms	289 ms
Sylvanu	160 ms	176 ms	188 ms

D'où mon assertion. Peut être est ce dû à la version XL

mapomme · 16 Décembre 2020

Bonjour à tous,

Une autre méthode que j'avais commencée puis abandonnée à la vue des performances de @job75 (soit dit en passant @job75, ton Intel a l'air super performant alors que sa fréquence est bonne mais pas les top des fréquences, est-ce parce que tu es en Excel 64 bits ?)
J'ai terminé ma méthode et la publie. Curieux de voir ce que cela donne sur vos PC.

VB:

Sub Modulo2()
Dim n&, t, tp, ti, i&, ni&, np&, m&, j&, deb

   deb = Timer: Application.ScreenUpdating = False
   n = Cells(Rows.Count, "c").End(xlUp).Row - 3: t = Range("c4").Resize(n)
   ni = [sum(mod(C4:C9999, 2))]: np = n - ni
   ReDim tp(1 To np), ti(1 To ni), r1(1 To np * (np - 1) / 2, 1 To 2)
   ReDim r2(1 To ni * (ni - 1) / 2, 1 To 2), r3(1 To np * ni, 1 To 2)

   ni = 0: np = 0
   For i = 1 To n
      If t(i, 1) Mod 2 = 0 Then
         np = np + 1: tp(np) = t(i, 1)
      Else
         ni = ni + 1: ti(ni) = t(i, 1)
      End If
   Next i

   For i = 1 To np: For j = i + 1 To np: m = m + 1: r1(m, 1) = tp(i): r1(m, 2) = tp(j): Next: Next
   m = 0: For i = 1 To ni: For j = i + 1 To ni: m = m + 1: r2(m, 1) = ti(i): r2(m, 2) = ti(j): Next: Next
   m = 0: For i = 1 To np: For j = 1 To ni: m = m + 1: r3(m, 1) = tp(i): r3(m, 2) = ti(j): Next: Next

   Range("e4").Resize(UBound(r1), 2) = r1: ange("h4").Resize(UBound(r2), 2) = r2: Range("k4").Resize(UBound(r3), 2) = r3
   MsgBox Format(Timer - deb, "0.00\ sec.")
End Sub

sylvanu · 16 Décembre 2020

Re le fil, bonjour Mapomme,
A iso périmètre :

	min	moyenne	max
Job	266 ms	281 ms	289 ms
Sylvanu	160 ms	176 ms	188 ms
MaPomme	74 ms	83 ms	86 ms

Pas mal !

Par contre, je ne comprends pas pourquoi il y a un tel écart.

job75 · 16 Décembre 2020

Bonjour mapomme,

Ta macro est super, chez moi elle s'exécute en 0,70 seconde.

@sylvanu : teste plutôt avec 1000 nombres en colonne C.

Maintenant un petit complément : lorsqu'il y a plus de 2047 nombres en colonne C la macro beugue car on dépasse les limites de la feuille.

Pour l'éviter voyez ce fichier (2) et ma macro modifiée :

VB:

Sub Combinaisons()
Dim t, tablo, rc&, resu1(), resu2(), resu3(), ub&, i&, j&, test As Byte, n1, n2, n3, dep1, dep2, dep3
t = Timer
tablo = [OFFSET(C4,,,COUNT(C:C))]
If IsArray(tablo) Then 'sécurité
    rc = Rows.Count - 3
    ReDim resu1(1 To rc, 1 To 2)
    ReDim resu2(1 To rc, 1 To 2)
    ReDim resu3(1 To rc, 1 To 2)
    ub = UBound(tablo)
    For i = 1 To ub - 1
        test = tablo(i, 1) Mod 2 'parité 1 ou 0
        For j = i + 1 To ub
            Select Case test + (tablo(j, 1) Mod 2)
                Case 0: n1 = n1 + 1: If n1 <= rc Then resu1(n1, 1) = tablo(i, 1): resu1(n1, 2) = tablo(j, 1)
                Case 2: n2 = n2 + 1: If n2 <= rc Then resu2(n2, 1) = tablo(i, 1): resu2(n2, 2) = tablo(j, 1)
                Case 1: n3 = n3 + 1: If n3 <= rc Then resu3(n3, 1) = tablo(IIf(test, j, i), 1): resu3(n3, 2) = tablo(IIf(test, i, j), 1)
            End Select
    Next j, i
End If
'---restitutions---
Application.ScreenUpdating = False
With ActiveSheet
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    .Range("E4:L" & .Rows.Count).ClearContents 'RAZ
    If n1 Then If n1 <= rc Then .[E4].Resize(n1, 2) = resu1 Else dep1 = n1 - rc
    If n2 Then If n2 <= rc Then .[H4].Resize(n2, 2) = resu2 Else dep2 = n2 - rc
    If n3 Then If n3 <= rc Then .[K4].Resize(n3, 2) = resu3 Else dep3 = n3 - rc
    With .UsedRange: End With 'actualise la barre de défilement verticale
End With
MsgBox "Durée des calculs " & Format(Timer - t, "0.00 \sec")
If dep1 Then MsgBox "Le tableau E4 dépasse les limites de la feuille de " & dep1 & " lignes !", 48
If dep2 Then MsgBox "Le tableau H4 dépasse les limites de la feuille de " & dep2 & " lignes !", 48
If dep3 Then MsgBox "Le tableau K4 dépasse les limites de la feuille de " & dep3 & " lignes !", 48
End Sub

A+

R@chid · 16 Décembre 2020

Bonjour @ tous,
@sylvanu
tu fais le test sur combien de nombre?
J'ai fait le test sur 1000 nombres :
mapomme : 1,30s
Job75 : 1,54s
Sylvanu : dépassement de capacité.

R@chid · 16 Décembre 2020

Re,

job75 à dit:
Bonjour R@chid, sylvanu, le forum,

Mon ordi est moins rapide que le tien en effet :

Processeur Intel(R) Core(TM) i7-8565 CPU @ 1.80GHz 1.99 GHz
Mémoire RAM installée 8,00 Go (7,89 Go utilisable)
Type du système Système d’exploitation 64 bits, processeur x64

Édition Windows 10 Famille
Version 2004
Version du système d’exploitation 19041.685
Expérience Windows Feature Experience Pack 120.2212.551.0

Excel 2019, Version 2011 (build 13426.20308) 64 bits

A+

Alors je dois prendre soin de ma Bécane

Microsoft 365 Multiplication chiffres pairs/impairs

Patron28

XLDnaute Nouveau

Pièces jointes

sylvanu

sylvanu

XLDnaute Barbatruc

Pièces jointes

Patron28

XLDnaute Nouveau

job75

XLDnaute Barbatruc

Pièces jointes

job75

XLDnaute Barbatruc

R@chid

XLDnaute Barbatruc

sylvanu

XLDnaute Barbatruc

Pièces jointes

job75

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

sylvanu

XLDnaute Barbatruc

mapomme

XLDnaute Barbatruc

Pièces jointes

sylvanu

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

Pièces jointes

R@chid

XLDnaute Barbatruc

R@chid

XLDnaute Barbatruc

Discussions similaires