Logo GNT
Actualités Tests & Guides Bons Plans
Twitter iPhone pliant OnePlus 11 PS5 Disney+ Orange Livebox Windows 11
Entraide Applications Microsoft Office Excel Recherche grand simplificateur!

Recherche grand simplificateur!

11 réponses
Avatar
Tatanka
Bonsoir, Bonsoir,

À votre avis, peut-on modifier cette macro
dans le but de la généraliser pour un
nombre de boucles variant de 2 à 16 ?
Fonction récursive, peut-être ?
Pour le moment, j'ai besoin d'un petit répit
et je vous salue bien bas ;-)

Sub Six()
Application.ScreenUpdating = False
Dim L
Sheets.Add
L = Array("R", "B")
For Each a In L
For Each b In L
For Each c In L
For Each d In L
For Each e In L
For Each f In L
n = n + 1
Cells(n, 1) = a
Cells(n, 2) = b
Cells(n, 3) = c
Cells(n, 4) = d
Cells(n, 5) = e
Cells(n, 6) = f
Next f
Next e
Next d
Next c
Next b
Next a
Columns("A:F").EntireColumn.AutoFit
Application.ScreenUpdating = True
End Sub

Merci et bonne soirée,
Serge
Signaler un problème avec ce contenu

10 réponses

Supprimer
Cette action est irreversible, confirmez la suppression du commentaire ?
Signaler le commentaire

Veuillez sélectionner un problème

Nudité
Violence
Harcèlement
Fraude
Vente illégale
Discours haineux
Terrorisme
Autre
1 2
Avatar
isabelle
bonjour Serge,

Sub huit()
For i = 1 To 64
Range("A" & i) = "'" & Format(Evaluate("DECBIN(" & i & ", 8)"), "00000000")
Next
Range("A1:A" & Range("A65536").End(xlUp).Row).TextToColumns Destination:=Range("A1"), _
DataType:=xlFixedWidth, FieldInfo:=Array(Array(0, 1), Array(1, 1), Array(2, 1), _
Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), Array(7, 1)), _
TrailingMinusNumbers:=True
Range("A:A").NumberFormat = "General"
End Sub

il reste à remplacer les 0 et 1 par ce que tu veut,

isabelle

Bonsoir, Bonsoir,

À votre avis, peut-on modifier cette macro
dans le but de la généraliser pour un
nombre de boucles variant de 2 à 16 ?
Fonction récursive, peut-être ?
Pour le moment, j'ai besoin d'un petit répit
et je vous salue bien bas ;-)

Sub Six()
Application.ScreenUpdating = False
Dim L
Sheets.Add
L = Array("R", "B")
For Each a In L
For Each b In L
For Each c In L
For Each d In L
For Each e In L
For Each f In L
n = n + 1
Cells(n, 1) = a
Cells(n, 2) = b
Cells(n, 3) = c
Cells(n, 4) = d
Cells(n, 5) = e
Cells(n, 6) = f
Next f
Next e
Next d
Next c
Next b
Next a
Columns("A:F").EntireColumn.AutoFit
Application.ScreenUpdating = True
End Sub

Merci et bonne soirée,
Serge




Avatar
isabelle
ps/

DECBIN à un maximun de 0 à 511 (10 caractères) = 0111111111

isabelle


bonjour Serge,

Sub huit()
For i = 1 To 64
Range("A" & i) = "'" & Format(Evaluate("DECBIN(" & i & ", 8)"), "00000000")
Next
Range("A1:A" & Range("A65536").End(xlUp).Row).TextToColumns
Destination:=Range("A1"), _
DataType:=xlFixedWidth, FieldInfo:=Array(Array(0, 1), Array(1, 1),
Array(2, 1), _
Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), Array(7, 1)), _
TrailingMinusNumbers:=True
Range("A:A").NumberFormat = "General"
End Sub

il reste à remplacer les 0 et 1 par ce que tu veut,

isabelle

Bonsoir, Bonsoir,

À votre avis, peut-on modifier cette macro
dans le but de la généraliser pour un
nombre de boucles variant de 2 à 16 ?
Fonction récursive, peut-être ?
Pour le moment, j'ai besoin d'un petit répit
et je vous salue bien bas ;-)

Sub Six()
Application.ScreenUpdating = False
Dim L
Sheets.Add
L = Array("R", "B")
For Each a In L
For Each b In L
For Each c In L
For Each d In L
For Each e In L
For Each f In L
n = n + 1
Cells(n, 1) = a
Cells(n, 2) = b
Cells(n, 3) = c
Cells(n, 4) = d
Cells(n, 5) = e
Cells(n, 6) = f
Next f
Next e
Next d
Next c
Next b
Next a
Columns("A:F").EntireColumn.AutoFit
Application.ScreenUpdating = True
End Sub

Merci et bonne soirée,
Serge





Avatar
Tatanka
Bonjour Isabelle,

Pas encore tout compris ta macro ;-(
Pour Huit, voici ce que je veux obtenir.
Je suis encore pogné avec des boucles mais en
passant par un tableau, ça simplifie un tipeu le code
et c'est drôlement plus rapide.

Sub Huit()
Application.ScreenUpdating = False
Dim L
Dim t()
n = 2 ^ 8
ReDim t(1 To n, 1 To 1)
Sheets.Add
L = Array("R", "B")
For Each a In L
For Each b In L
For Each c In L
For Each d In L
For Each e In L
For Each f In L
For Each g In L
For Each h In L
i = i + 1
t(i, 1) = a & b & c & d & e & f & g & h
Next h
Next g
Next f
Next e
Next d
Next c
Next b
Next a
Range(Cells(1, 1), Cells(n, 1)).Value = t
Columns("A").EntireColumn.AutoFit
Application.ScreenUpdating = True
End Sub

Serge


"isabelle" a écrit dans le message de news: Oap$
ps/

DECBIN à un maximun de 0 à 511 (10 caractères) = 0111111111

isabelle


bonjour Serge,

Sub huit()
For i = 1 To 64
Range("A" & i) = "'" & Format(Evaluate("DECBIN(" & i & ", 8)"), "00000000")
Next
Range("A1:A" & Range("A65536").End(xlUp).Row).TextToColumns Destination:=Range("A1"), _
DataType:=xlFixedWidth, FieldInfo:=Array(Array(0, 1), Array(1, 1), Array(2, 1), _
Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), Array(7, 1)), _
TrailingMinusNumbers:=True
Range("A:A").NumberFormat = "General"
End Sub

il reste à remplacer les 0 et 1 par ce que tu veut,

isabelle

Bonsoir, Bonsoir,

À votre avis, peut-on modifier cette macro
dans le but de la généraliser pour un
nombre de boucles variant de 2 à 16 ?
Fonction récursive, peut-être ?
Pour le moment, j'ai besoin d'un petit répit
et je vous salue bien bas ;-)

Sub Six()
Application.ScreenUpdating = False
Dim L
Sheets.Add
L = Array("R", "B")
For Each a In L
For Each b In L
For Each c In L
For Each d In L
For Each e In L
For Each f In L
n = n + 1
Cells(n, 1) = a
Cells(n, 2) = b
Cells(n, 3) = c
Cells(n, 4) = d
Cells(n, 5) = e
Cells(n, 6) = f
Next f
Next e
Next d
Next c
Next b
Next a
Columns("A:F").EntireColumn.AutoFit
Application.ScreenUpdating = True
End Sub

Merci et bonne soirée,
Serge







Avatar
Brunos
Bonsoir, Bonsoir,

À votre avis, peut-on modifier cette macro
dans le but de la généraliser pour un
nombre de boucles variant de 2 à 16 ?
Fonction récursive, peut-être ?
Pour le moment, j'ai besoin d'un petit répit
et je vous salue bien bas ;-)

Sub Six()
Application.ScreenUpdating = False
Dim L
Sheets.Add
L = Array("R", "B")
For Each a In L
For Each b In L
For Each c In L
For Each d In L
For Each e In L
For Each f In L
n = n + 1
Cells(n, 1) = a
Cells(n, 2) = b
Cells(n, 3) = c
Cells(n, 4) = d
Cells(n, 5) = e
Cells(n, 6) = f
Next f
Next e
Next d
Next c
Next b
Next a
Columns("A:F").EntireColumn.AutoFit
Application.ScreenUpdating = True
End Sub

Merci et bonne soirée,
Serge


Bonsoir Serge,

Sub DeuxANeuf()
Application.ScreenUpdating = False
Dim Binaire()
N = InputBox("Valeur de 2 à 9", , 2)
If N < 2 Or N > 9 Or Not IsNumeric(N) Then End
ReDim Binaire(1 To 2 ^ N)
Sheets.Add
For i = 1 To 2 ^ N
Binaire(i) = WorksheetFunction.Dec2Bin(i - 1, N)
For j = 1 To N
If Mid(Binaire(i), j, 1) Then Cells(i, j) = "B" _
Else Cells(i, j) = "R"
Next
Next
Columns("A:J").EntireColumn.AutoFit
Application.ScreenUpdating = True
End Sub

C'est limité à 9 car la méthode Dec2Bin (x,y) est limitée à 2^9 pour x.
Il faut un autre convertisseur Décimal vers binaire pour aller plus
loin, mais ça doit être facile à trouver.

NB : j'avais pas encore vu la soluce d'Isabelle, je jure que j'ai pas
copié !!!

Brunos

--
Brunos

Avatar
Modeste
Bonsour® isabelle avec ferveur ;o))) vous nous disiez :

Range("A" & i) = "'" & Format(Evaluate("DECBIN(" & i & ", 8)"),


DECBIN ne va que jusque 512 soit 10 positions binaires

de toute façon AV ne le répétera jamais assez :
"Evitez autant que faire ce peut" les fonctions des macro-complémentaires !!!
;o)))


--
--
@+
;o)))

Avatar
Modeste
Bonsour® Tatanka avec ferveur ;o))) vous nous disiez :

généraliser pour un nombre variant de 2 à 16 ?

SubTatanka()
Dim n As Integer
Application.ScreenUpdating = True
n = CInt(InputBox("Nombre de positions ( 2 à 16)", "TATANKA"))
If n < 3 Or n > 16 Then Exit Sub
Sheets.Add
For i = 1 To 2 ^ n
Cells(i, 1) = "'" & DVB(i - 1, n) '
Cells(i, 2).FormulaR1C1 =
"=SUBSTITUTE(SUBSTITUTE(RC[-1],""0"",""B""),""1"",""R"")"
Next
Columns("A:B").EntireColumn.AutoFit
Application.ScreenUpdating = True

End Sub

Function DVB(NombreDecimal As Long, affiche As Integer) As String
Dim Resultat As String
Dim LeDecimal As Long
LeDecimal = Abs(NombreDecimal)
Resultat = ""
Do While LeDecimal <> 0
Resultat = LeDecimal Mod 2 & Resultat
LeDecimal = LeDecimal 2
Loop
DVB = Right(String(affiche, "0") & Resultat, affiche)
End Function



--
--
@+
;o)))
Avatar
Brunos
Bonsour® Tatanka avec ferveur ;o))) vous nous disiez :

généraliser pour un nombre variant de 2 à 16 ?


Pourquoi que jusqu'à 16 ? J'irai jusqu'à 20 c'est mieux ;-)
avec excel 2007 ! :oÞ

Brunos

--
Brunos

Avatar
isabelle
alors dans la même optique (temps d'execution 10 sec),

Sub Seize_1()

Application.ScreenUpdating = False
Dim L
Dim t()
n = 2 ^ 16
ReDim t(1 To n, 1 To 1)
Sheets.Add
Range("S2") = Now
L = Array("R", "B")
For Each a In L
For Each b In L
For Each c In L
For Each d In L
For Each e In L
For Each f In L
For Each g In L
For Each h In L
For Each i In L
For Each j In L
For Each k In L
For Each m In L
For Each n In L
For Each o In L
For Each p In L
For Each q In L
z = z + 1
t(z, 1) = a & b & c & d & e & f & g & h & i & j & k & m & n & o & p & q
Next q
Next p
Next o
Next n
Next m
Next k
Next j
Next i
Next h
Next g
Next f
Next e
Next d
Next c
Next b
Next a
Range(Cells(1, 1), Cells(65536, 1)).Value = t
Range("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlFixedWidth, _
FieldInfo:=Array(Array(0, 1), Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array _
(5, 1), Array(6, 1), Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1), Array _
(12, 1), Array(13, 1), Array(14, 1), Array(15, 1)), TrailingMinusNumbers:=True

With Columns("A:P")
.ColumnWidth = 3
.HorizontalAlignment = xlCenter
End With
Application.ScreenUpdating = True
Range("S3") = Now
End Sub

isabelle

Bonjour Isabelle,

Pas encore tout compris ta macro ;-(
Pour Huit, voici ce que je veux obtenir.
Je suis encore pogné avec des boucles mais en
passant par un tableau, ça simplifie un tipeu le code
et c'est drôlement plus rapide.

Sub Huit()
Application.ScreenUpdating = False
Dim L
Dim t()
n = 2 ^ 8
ReDim t(1 To n, 1 To 1)
Sheets.Add
L = Array("R", "B")
For Each a In L
For Each b In L
For Each c In L
For Each d In L
For Each e In L
For Each f In L
For Each g In L
For Each h In L
i = i + 1
t(i, 1) = a & b & c & d & e & f & g & h
Next h
Next g
Next f
Next e
Next d
Next c
Next b
Next a
Range(Cells(1, 1), Cells(n, 1)).Value = t
Columns("A").EntireColumn.AutoFit
Application.ScreenUpdating = True
End Sub

Serge


"isabelle" a écrit dans le message de news: Oap$
ps/

DECBIN à un maximun de 0 à 511 (10 caractères) = 0111111111

isabelle


bonjour Serge,

Sub huit()
For i = 1 To 64
Range("A" & i) = "'" & Format(Evaluate("DECBIN(" & i & ", 8)"), "00000000")
Next
Range("A1:A" & Range("A65536").End(xlUp).Row).TextToColumns Destination:=Range("A1"), _
DataType:=xlFixedWidth, FieldInfo:=Array(Array(0, 1), Array(1, 1), Array(2, 1), _
Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), Array(7, 1)), _
TrailingMinusNumbers:=True
Range("A:A").NumberFormat = "General"
End Sub

il reste à remplacer les 0 et 1 par ce que tu veut,

isabelle

Bonsoir, Bonsoir,

À votre avis, peut-on modifier cette macro
dans le but de la généraliser pour un
nombre de boucles variant de 2 à 16 ?
Fonction récursive, peut-être ?
Pour le moment, j'ai besoin d'un petit répit
et je vous salue bien bas ;-)

Sub Six()
Application.ScreenUpdating = False
Dim L
Sheets.Add
L = Array("R", "B")
For Each a In L
For Each b In L
For Each c In L
For Each d In L
For Each e In L
For Each f In L
n = n + 1
Cells(n, 1) = a
Cells(n, 2) = b
Cells(n, 3) = c
Cells(n, 4) = d
Cells(n, 5) = e
Cells(n, 6) = f
Next f
Next e
Next d
Next c
Next b
Next a
Columns("A:F").EntireColumn.AutoFit
Application.ScreenUpdating = True
End Sub

Merci et bonne soirée,
Serge











Avatar
charabeuh
bonjour,

avec récursivité - dans module1 - fonctionne de 0 à 16 (en se limitant à une colonne)

Option Explicit

Const Car1 = "R", Car2 = "B"

Public Function nieme(Ordre As Integer, Rang As Long) As String
If Ordre = 0 Then
nieme = ""
ElseIf Rang Mod 2 = 0 Then
nieme = nieme(Ordre - 1, Rang 2) & Car1
Else
nieme = nieme(Ordre - 1, Rang 2) & Car2
End If
End Function


Sub afficher()
Dim i As Long, xOrdre As Integer
Range("A:A").ClearContents
xOrdre = InputBox("Nombre de caractères par cellule =?")
Application.ScreenUpdating = False
For i = 1 To (2 ^ xOrdre)
Range("A1").Offset(i - 1, 0).Value = nieme(xOrdre, i - 1)
Next i
Application.ScreenUpdating = True
End Sub


voir http://cjoint.com/?ccfviZGmxD

vu l'heure, bonjour !


"Tatanka" a écrit dans le message de news:
Bonsoir, Bonsoir,

À votre avis, peut-on modifier cette macro
dans le but de la généraliser pour un
nombre de boucles variant de 2 à 16 ?
Fonction récursive, peut-être ?
Pour le moment, j'ai besoin d'un petit répit
et je vous salue bien bas ;-)

Sub Six()
Application.ScreenUpdating = False
Dim L
Sheets.Add
L = Array("R", "B")
For Each a In L
For Each b In L
For Each c In L
For Each d In L
For Each e In L
For Each f In L
n = n + 1
Cells(n, 1) = a
Cells(n, 2) = b
Cells(n, 3) = c
Cells(n, 4) = d
Cells(n, 5) = e
Cells(n, 6) = f
Next f
Next e
Next d
Next c
Next b
Next a
Columns("A:F").EntireColumn.AutoFit
Application.ScreenUpdating = True
End Sub

Merci et bonne soirée,
Serge



Avatar
charabeuh
Bjr,

La récursivité est basée sur le fait que passer d'un mot de n lettres à n+1 lettres consiste a prendre chaque combinaison de n
lettres et de lui rajouter une fois la lettre R et une autre la lettre B.

Pour un mot de n lettres il y a 2^n combinaisons (le premier étant numéroté 0, le dernier 2^n - 1)
la ième combinaison (i paire) à n lettres est construite à partir de la (ième/2) combinaison n-1.(à laquelle on rajoute R)
la ième+1 combinaison (donc impaire) à n lettres est construite aussi à partir de la (ième/2) combinaison n-1.(mais à laquelle on
rajoute R)
Enfin quand on arrive à 0 (mot de longueur 0, on retourne la chaine vide "")

le code du module:

Option Explicit

Const Car1 = "R", Car2 = "B"

Public Function nieme(Ordre As Integer, Rang As Long) As String
If Ordre = 0 Then
nieme = ""
ElseIf Rang Mod 2 = 0 Then
nieme = nieme(Ordre - 1, Rang 2) & Car1
Else
nieme = nieme(Ordre - 1, Rang 2) & Car2
End If
End Function

Sub afficher()
Dim i As Long, xOrdre As Integer, j As Integer, Mot As String
Range("A:P").ClearContents
xOrdre = InputBox("Nombre de caractères par cellule =?")
For i = 1 To (2 ^ xOrdre)
Mot = nieme(xOrdre, i - 1)
For j = 1 To xOrdre
Range("A1").Offset(i - 1, j - 1).Value = Mid(Mot, j, 1)
Next j
Next i
End Sub


Slt
1 2