Optimiser un boucle
g
Bonsoir
je cherche une solution moins volumineuse pour la boucle M sur 4 que je souhaite sur 50
merci d'avance
For M = 1 To 4
Select Case M
Case 1
Set Rg = .Range("K1").Resize(, 7)
Set Rg2 = .Range("C6:Q15")
Case 2
Set Rg = .Range("R1").Resize(, 7)
Set Rg2 = .Range("R6:X15")
Case 3
Set Rg = .Range("Y1").Resize(, 7)
Set Rg2 = .Range("Y6:AE15")
Case 4
Set Rg = .Range("AF1").Resize(, 7)
Set Rg2 = .Range("AF6:AL15")
End Select
M
Bonsoir,
For M = 1 To 4
Set Rg = .Cells(1, 7 * M + 4).Resize(, 7)
Set Rg2 = Rg.Offset(5).Resize(10)
Next M
Faudrait peut-être faire autre chose dans la boucle aussi...
g
Bonsoir,
For M = 1 To 4 Set Rg = .Cells(1, 7 * M + 4).Resize(, 7) Set Rg2 = Rg.Offset(5).Resize(10) Next M
Faudrait peut-être faire autre chose dans la boucle aussi...
re merci
Oui voici la macro de depart!
Option Explicit
Sub Test()
Dim NbChiffres As Long, A As Long
Dim B As Long, Rg As Range, Nb As Long
Dim D As Object, T(), Rg2 As Range
Dim Compteur As Long, P As Variant
Dim Exp(), Elt As Variant, K(), M As Long
Dim Trouve As Range, Adr As String, X As Long
Dim S As Long, Z As Variant, G As Long
Dim Message As String, Liste As String
Dim GestionErreur As String
On Error GoTo GestionErreur
Application.ScreenUpdating = False
Application.EnableEvents = False
Nb = 7
NbChiffres = 7
Exp = Array("OUI", "NON", "PEUT ETRE")
For M = 1 To 2
With Worksheets("Feuil1")
If M = 1 Then
Set Rg = .Range("AA1").Resize(, 7)
Set Rg2 = .Range("C1:i10")
Else
Set Rg = .Range("AH1").Resize(, 7)
Set Rg2 = .Range("J1:P10")
End If
ReDim T(1 To Nb)
For A = 1 To NbChiffres
For Each Elt In Exp
With Rg2.Columns(A)
Set Trouve = .Find(What:=Elt, LookIn:=xlValues, LookAt:=xlWhole)
If Not Trouve Is Nothing Then
Adr = Trouve.Address
Do
S = S + 1
ReDim Preserve K(1 To S)
K(S) = Trouve.Row
Set Trouve = .FindNext(Trouve)
Loop Until Trouve.Address = Adr
End If
End With
Next
If IsNumeric(Rg(1, A).Value) Then
S = S + 1
ReDim Preserve K(1 To S)
K(S) = Rg(1, A)
End If
If UBound(K) >= 4 Then
Message = Message & "Impossible de former une combinaision avec la ligne " & A & "." & vbCrLf
Erase K: S = 0: Adr = ""
G = G + 3
Else
Set D = CreateObject("Scripting.Dictionary")
Do While Nb > Compteur
Randomize
X = Application.RandBetween(1, 10)
If IsError(Application.Match(X, K, 0)) Then
If Not D.Exists(CLng(X)) Then
D.Add X, A
Compteur = Compteur + 1
Liste = Liste & X & "-"
End If
End If
Loop
Liste = Left(Liste, Len(Liste) - 1)
T(A) = Liste: B = 1
Compteur = 0
Erase K: S = 0: Adr = ""
Set D = Nothing
Z = Split(Liste, "-")
.Range("C14").Offset(G).Resize(, 7).Value = Z
G = G + 3
Liste = ""
End If
Next
End With
Next
Application.ScreenUpdating = True
Application.EnableEvents = True
If Message <> "" Then
MsgBox "Liste des lignes du tableau où on ne peut pas " & vbCrLf & _
"générer une combinaison de 7 chiffres différents." & _
vbCrLf & vbCrLf & Message
End If
Exit Sub
GestionErreur:
MsgBox Err.Number & ", " & Err.Description
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub