Recherche grand simplificateur!

Le
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
Vidéos High-Tech et Jeu Vidéo
Téléchargements
Vos réponses Page 1 / 2
Gagnez chaque mois un abonnement Premium avec GNT : Inscrivez-vous !
Trier par : date / pertinence
isabelle
Le #5146031
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




isabelle
Le #5146001
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





Tatanka
Le #5145981
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







Brunos
Le #5145961
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

Modeste
Le #5145951
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)))

Modeste
Le #5145941
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)))
Brunos
Le #5145921
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

isabelle
Le #5145881
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











charabeuh
Le #5284631
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"
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



charabeuh
Le #5284231
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
Publicité
Poster une réponse
Anonyme