Optimiser un boucle

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 

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...

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
Rechercher des sujets similaires à "optimiser boucle"