Sub prout()
Dim i%, j%, k%, l%, Msg$, n&, s&, xy(), x%(), y%()
xy = Range("A1:B4").Value
s = UBound(xy)
ReDim x(1 To s, 1 To 1)
ReDim y(1 To s)
For i = 1 To s: y(i) = xy(i, 2): Next
Erase xy
For i = 1 To y(4)
For j = 1 To y(1)
For k = 1 To y(3)
For l = 1 To y(2)
' Mettre ici la "vérification" souhaitée. Par exemple,
' "Relever les cas où i*j*k*l est multiple de 5" :
If i Mod 5 = 0 Or j Mod 5 = 0 Or k Mod 5 = 0 Or l Mod 5 = 0 Then
n = n + 1
ReDim Preserve x(1 To s, 1 To n)
x(1, n) = i: x(2, n) = j: x(3, n) = k: x(4, n) = l
End If
'
Next l, k, j, i
With Range("H2")
If n > Rows.Count - .Row + 1 Then
Msg = "Il y a " & Format(n, "# ##0") & " résultats. Ils n'ont pas pu être tous affichés."
n = Rows.Count - .Row + 1
ReDim Preserve x(1 To s, 1 To n)
End If
With Application: .ScreenUpdating = 0: .Calculation = -4135: .EnableEvents = 0: End With
.Resize(Rows.Count - .Row + 1, s).ClearContents
.Resize(n, s).Value = WorksheetFunction.Transpose(x)
With Application: .EnableEvents = 1: .Calculation = -4105: .ScreenUpdating = 1: End With
End With
If Len(Msg) Then MsgBox Msg
End Sub
Sub tez()
Dim a, b, c, d As String
Application.ScreenUpdating = False
a = Cells(2, 4)
b = Cells(3, 4)
c = Cells(4, 4)
d = Cells(5, 4)
For w = 1 To d
Cells(4, 1) = w
For x = 1 To c
Cells(3, 1) = x
For y = 1 To b
Cells(2, 1) = y
For Z = 1 To a
Cells(1, 1) = Z
Next
Next
Next
Next
Application.ScreenUpdating = True
End Sub
Sub Start()
Dim i&, j&, k&, l&, Msg$, n&, s&, xy(), x&(), y&()
Dim d&
xy = Range("D2:D5").Value
d = Range("G6").Value
s = UBound(xy)
ReDim x(1 To 1)
ReDim y(1 To s)
For i = 1 To s: y(i) = xy(i, 1): Next
Erase xy
For i = 1 To y(4)
For j = 1 To y(1)
For k = 1 To y(3)
For l = 1 To y(2)
If (i * j * k * l) Mod d = 0 Then
n = n + 1
ReDim Preserve x(1 To n)
x(n) = i * j * k * l
Exit For
End If
Next l, k, j, i
With Range("J1")
If n > Rows.Count - .Row + 1 Then
Msg = "Il y a " & Format(n, "# ##0") & " résultats. Ils n'ont pas pu être tous affichés."
n = Rows.Count - .Row + 1
ReDim Preserve x(1 To n)
End If
With Application: .ScreenUpdating = 0: .Calculation = -4135: .EnableEvents = 0: End With
.Resize(Rows.Count - .Row + 1, 1).ClearContents
If n Then .Resize(n, 1).Value = WorksheetFunction.Transpose(x)
With Application: .EnableEvents = 1: .Calculation = -4105: .ScreenUpdating = 1: End With
End With
If Len(Msg) Then MsgBox Msg
End Sub
Salut,
Merci à tous. Grâce à votre aide j'ai pu réduire de 70% le temps de traitement.
@+
Sub tez()
Application.ScreenUpdating = False
Range("j1:j1000") = ""
a = Cells(2, 4)
b = Cells(3, 4)
c = Cells(4, 4)
d = Cells(5, 4)
g = Range("G6")
For w = 1 To d
Cells(4, 1) = w
For x = 1 To c
Cells(3, 1) = x
For y = 1 To b
Cells(2, 1) = y
For Z = 1 To a
Cells(1, 1) = Z
If Range("G1") Mod g = 0 Then
t = t + 1
Cells(t, 10) = Range("g1")
Exit For
Else
End If
Next
Next
Next
Next
Application.ScreenUpdating = True
End Sub
(...)
Voici le code final qui divise par deux le temps de traitement.
(...)
Sub tez()
Dim a&, b&, c&, d&, g&, t&, w&, x&, y&, z&
Application.ScreenUpdating = False
Range("J2:J1000") = ""
a = Cells(2, 4)
b = Cells(3, 4)
c = Cells(4, 4)
d = Cells(5, 4)
g = Range("G6")
t = 1
For w = 1 To d
Cells(4, 1) = w
For x = 1 To c
Cells(3, 1) = x
For y = 1 To b
Cells(2, 1) = y
For z = 1 To a
Cells(1, 1) = z
If Range("G1") Mod g = 0 Then
t = t + 1
Cells(t, 10) = Range("G1")
y = b
x = c
Exit For
End If
Next z
Next y
Next x
Next w
Application.ScreenUpdating = True
End Sub
Sub Start()
Dim i&, j&, k&, l&, Msg$, n&, s&, xy(), x&(), y&()
Dim d&
xy = Range("D2:D5").Value
d = Range("G6").Value
s = UBound(xy)
ReDim x(1 To 1)
ReDim y(1 To s)
For i = 1 To s: y(i) = xy(i, 1): Next
Erase xy
For i = 1 To y(4)
For j = 1 To y(3)
For k = 1 To y(2)
For l = 1 To y(1)
If (i * j * k * l) Mod d = 0 Then
n = n + 1
ReDim Preserve x(1 To n)
x(n) = i * j * k * l
j = y(3)
k = y(2)
Exit For
End If
Next l, k, j, i
With Range("J2")
If n > Rows.Count - .Row + 1 Then
Msg = "Il y a " & Format(n, "# ##0") & " résultats. Ils n'ont pas pu être tous affichés."
n = Rows.Count - .Row + 1
ReDim Preserve x(1 To n)
End If
With Application: .ScreenUpdating = 0: .Calculation = -4135: .EnableEvents = 0: End With
.Resize(Rows.Count - .Row + 1, 1).ClearContents
If n Then .Resize(n, 1).Value = WorksheetFunction.Transpose(x)
With Application: .EnableEvents = 1: .Calculation = -4105: .ScreenUpdating = 1: End With
End With
If Len(Msg) Then MsgBox Msg
End Sub
(...)
très troublé par différents tests
(...)
(...)
Voilà la logique que je cherche à réaliser.
A1 = 1 / A2 = 1 / A3 = 1 / A4 = 1
A1 = 2 / A2 = 1 / A3 = 1 / A4 = 1
A1 = 1 / A2 = 2 / A3 = 1 / A4 = 1
A1 = 2 / A2 = 2 / A3 = 1 / A4 = 1 ->>> Enregistrement puis arret pour faire A4 = A4 + 1 car multiple de 4
A1 = 1 / A2 = 1 / A3 = 2 / A4 = 1
A1 = 2 / A2 = 1 / A3 = 2 / A4 = 1
A1 = 1 / A2 = 2 / A3 = 2 / A4 = 1 ->>> Enregistrement puis arret pour faire A4 = A4 + 1 car multiple de 4
A1 = 2 / A2 = 2 / A3 = 2 / A4 = 1
A1 = 1 / A2 = 1 / A3 = 1 / A4 = 2
A1 = 2 / A2 = 1 / A3 = 1 / A4 = 2
A1 = 1 / A2 = 2 / A3 = 1 / A4 = 2
A1 = 2 / A2 = 2 / A3 = 1 / A4 = 2
A1 = 1 / A2 = 1 / A3 = 2 / A4 = 2
A1 = 2 / A2 = 1 / A3 = 2 / A4 = 2
A1 = 1 / A2 = 2 / A3 = 2 / A4 = 2
A1 = 2 / A2 = 2 / A3 = 2 / A4 = 2
Et à chaque fois qu'un multiple est trouvé la valeur est enregistrée.
(...)
(...)
Voilà la logique que je cherche à réaliser.
A1 = 1 / A2 = 1 / A3 = 1 / A4 = 1
A1 = 2 / A2 = 1 / A3 = 1 / A4 = 1
A1 = 1 / A2 = 2 / A3 = 1 / A4 = 1
A1 = 2 / A2 = 2 / A3 = 1 / A4 = 1 ->>> Enregistrement puis arret pour faire A4 = A4 + 1 car multiple de 4
A1 = 1 / A2 = 1 / A3 = 2 / A4 = 1
A1 = 2 / A2 = 1 / A3 = 2 / A4 = 1 ->>> Enregistrement puis arret pour faire A4 = A4 + 1 car multiple de 4
A1 = 1 / A2 = 2 / A3 = 2 / A4 = 1 ->>> Enregistrement puis arret pour faire A4 = A4 + 1 car multiple de 4
A1 = 2 / A2 = 2 / A3 = 2 / A4 = 1 ->>> Enregistrement puis arret pour faire A4 = A4 + 1 car multiple de 4
A1 = 1 / A2 = 1 / A3 = 1 / A4 = 2
A1 = 2 / A2 = 1 / A3 = 1 / A4 = 2 ->>> Enregistrement puis arret pour faire A4 = A4 + 1 car multiple de 4
A1 = 1 / A2 = 2 / A3 = 1 / A4 = 2 ->>> Enregistrement puis arret pour faire A4 = A4 + 1 car multiple de 4
A1 = 2 / A2 = 2 / A3 = 1 / A4 = 2 ->>> Enregistrement puis arret pour faire A4 = A4 + 1 car multiple de 4
A1 = 1 / A2 = 1 / A3 = 2 / A4 = 2 ->>> Enregistrement puis arret pour faire A4 = A4 + 1 car multiple de 4
A1 = 2 / A2 = 1 / A3 = 2 / A4 = 2 ->>> Enregistrement puis arret pour faire A4 = A4 + 1 car multiple de 4
A1 = 1 / A2 = 2 / A3 = 2 / A4 = 2 ->>> Enregistrement puis arret pour faire A4 = A4 + 1 car multiple de 4
A1 = 2 / A2 = 2 / A3 = 2 / A4 = 2 ->>> Enregistrement puis arret pour faire A4 = A4 + 1 car multiple de 4
Et à chaque fois qu'un multiple est trouvé la valeur est enregistrée.
(...)