Microsoft 365 Multiplication chiffres pairs/impairs

P

Patron28

XLDnaute Nouveau
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.
 

Pièces jointes

Solution
sylvanu
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...
Trier par date Trier par votes
sylvanu

sylvanu

XLDnaute Barbatruc
Supporter XLD
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
 

Pièces jointes

Vote positif 0 Vote négatif
Solution
job75

job75

XLDnaute Barbatruc
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+
 

Pièces jointes

Dernière édition:
Vote positif 0 Vote négatif
R@chid

R@chid

XLDnaute Barbatruc
Supporter XLD
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.
Cliquez pour agrandir...

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
 
Vote positif 0 Vote négatif
sylvanu

sylvanu

XLDnaute Barbatruc
Supporter XLD
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
 

Pièces jointes

Dernière édition:
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Bonjour R@chid, sylvanu, le forum,
R@chid à dit:
]e ne sais pas pourquoi ça appris 17 secondes chez toi ? 🤔 🤔
Cliquez pour agrandir...
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+
 
Vote positif 0 Vote négatif
mapomme

mapomme

XLDnaute Barbatruc
Supporter XLD
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
 

Pièces jointes

Dernière édition:
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
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+
 

Pièces jointes

Vote positif 0 Vote négatif
R@chid

R@chid

XLDnaute Barbatruc
Supporter XLD
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+
Cliquez pour agrandir...

Alors je dois prendre soin de ma Bécane :):)
 
Vote positif 0 Vote négatif

Discussions similaires

M
  • Résolu(e)
XL pour MAC Tirages aléatoires avec critères
2
Réponses
16
Affichages
664
crocrocro
C
Phil Du59
  • Résolu(e)
Microsoft 365 Tableau de STATS sur autre feuille
Réponses
8
Affichages
339
AtTheOne
AtTheOne
JohnBill
  • Question Question
XL 2021 Doublons
Réponses
2
Affichages
308
JohnBill
JohnBill
cathodique
  • Résolu(e)
XL 2010 Mauvaise utilisation de la fonction InStr
Réponses
11
Affichages
630
jurassic pork
jurassic pork
D
  • Question Question
XL 2013 recopier dans d'autres feuilles des lignes en fonction d'un critère
Réponses
9
Affichages
400
sylvanu
sylvanu
F
  • Résolu(e)
Microsoft 365 Rassembler les données de plusieurs feuilles dans une feuille récapitulative
2
Réponses
19
Affichages
2 K
cp4
cp4
B
  • Question Question
XL 2013 Automatiser une formule sur les nouvelles lignes insérées en fonction d'une recherche sur les enregistrements
Réponses
9
Affichages
487
bedley
B
TB_AHE
  • Question Question
Microsoft 365 Créer une Document Word à partir de champs et listes
2
Réponses
15
Affichages
1 K
Compte Supprimé 979
C
H
  • Résolu(e)
XL 2019 Récupération de résultats depuis un CSV vers un fichier Excel
Réponses
9
Affichages
866
Hutchy33
H
J
  • Résolu(e)
XL 2013 Macro et script vba : macro s'arrête dès la première condition trouvée
Réponses
11
Affichages
831
Janu44
J
D
  • Question Question
XL 2013 envoie tableau dans corp du mail vba
2
Réponses
26
Affichages
2 K
David62800
D
D
  • Résolu(e)
XL 2013 Modification Code | Fonction ListSort2() | BoisgontierJacques
Réponses
3
Affichages
491
Dae_mon
D
E
  • Question Question
Microsoft 365 Reporter les valeurs d'une colonne dans une autre tous les 3 lignes
Réponses
2
Affichages
612
Eric32000
E
L
  • Question Question
XL 2016 Recherche de partie de mot dans les cellules d'un tableau et extractions des résultats
2
Réponses
29
Affichages
2 K
Lorenzini
L
C
  • Question Question
Microsoft 365 VBA-Comparaison de données
Réponses
4
Affichages
756
CyrilTD
C
C
  • Question Question
Microsoft 365 trouver le nombre de référence unique dans une colonne en fonction de critères de deux autres colonnes
Réponses
4
Affichages
861
R@chid
R@chid
B
  • Question Question
XL 2019 Mail d'alerte automatique contenant tableau si condition remplie
Réponses
2
Affichages
802
fanch55
fanch55
E
  • Question Question
XL 2016 Comparer des chiffres possédant le même titre
Réponses
12
Affichages
676
Erakmur
E
suzannegobeil
  • Résolu(e)
XL 2016 Créer Macro pour imprimer un nombre d'étiquettes en fonction d'une colonne Excel "Quantité"
Réponses
4
Affichages
1 K
suzannegobeil
suzannegobeil
K
  • Question Question
XL 2016 Conserver les données uniques (VBA)
Réponses
7
Affichages
1 K
Hasco
Hasco

Membres actuellement en ligne

21 membres et 358 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
315 285
Messages
2 118 029
Membres
113 416
dernier inscrit
rr69