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

  • PairsImpairs.xlsx
    10.3 KB · Affichages: 36
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

  • PairsImpairs (1).xlsm
    19.5 KB · Affichages: 16
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

  • PairsImpairs(1).xlsm
    21.2 KB · Affichages: 16
Dernière édition:
Vote positif 0 Vote négatif
R@chid

R@chid

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

  • PairsImpairs (2).xlsm
    21.3 KB · Affichages: 10
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

  • Patron28- PairsImpairs- v1.xlsm
    29.8 KB · Affichages: 9
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

  • PairsImpairs(2).xlsm
    44.2 KB · Affichages: 9
Vote positif 0 Vote négatif
R@chid

R@chid

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

D
  • Question
XL 2013 recopier dans d'autres feuilles des lignes en fonction d'un critère
Réponses
9
Affichages
215
sylvanu
sylvanu
F
  • Question
Microsoft 365 Rassembler les données de plusieurs feuilles dans une feuille récapitulative
2
Réponses
19
Affichages
1 K
cp4
cp4
B
  • 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
229
bedley
B
TB_AHE
  • Question
Microsoft 365 Créer une Document Word à partir de champs et listes
2
Réponses
15
Affichages
772
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
556
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
432
Janu44
J
D
  • Question
XL 2013 envoie tableau dans corp du mail vba
2
Réponses
26
Affichages
954
David62800
D
D
  • Résolu(e)
XL 2013 Modification Code | Fonction ListSort2() | BoisgontierJacques
Réponses
3
Affichages
410
Dae_mon
D
E
  • Question
Microsoft 365 Reporter les valeurs d'une colonne dans une autre tous les 3 lignes
Réponses
2
Affichages
424
Eric32000
E
L
  • Question
XL 2016 Recherche de partie de mot dans les cellules d'un tableau et extractions des résultats
2
Réponses
29
Affichages
1 K
Lorenzini
L

Membres actuellement en ligne

15 membres et 129 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
312 219
Messages
2 086 369
Membres
103 197
dernier inscrit
sandrine.lacaussade@orang