XL 2021 Double boucle

[whiteshark]

Bonjour la communauté !

J’ai une fois de plus besoin d’aide et je fais appel à vous.

Je vais essayer d’être clair dans mon explication. J’essaie avec un fichier Excel de gérer un transfert semi-automatique de données. J’ai des dossiers bruts en sortie de serveur que je veux grâce à une macros envoyer semi-automatiquement (semi parce que c’est moi qui déclenche le transfert) vers les bons services. Lorsqu’un utilisateur à besoin d’utiliser le serveur il remplit un tableau (simulé par la Feuil1) dont les infos sont traitées dans Tableau de transition. Les jeux de données sont traités par run. En sortie de serveur le dossier brut de données traitées se nomme BRUT_date du run_N° du run. Normalement c’est moi qui copie ce dossier du serveur vers le bon service en le renommant avec le nom de l’utilisateur : Sam_date du run_N° du run. Lorsque le dossier renommé a été transféré je mets une x dans Feuil1 à la bonne ligne pour signaler que le transfert à bien été fait.

Du coup j’ai tenté de faire une macro qui automatise tout ça. En gros j’ai fait en sorte que dans Tableau de transition toutes les infos soient présentes, je mets la mention AT devant chaque ligne où un transfert est nécessaire et je clique sur un bouton. Avec une boucle sur la colonne B pour scanner tous les AT ça marchait très bien sauf que je dois intriquer une deuxième boucle dans cette première pour gérer le décalage dû au week-end. La macro cherche les dossiers à la date du jours pour les transférer et avec la deuxième boucle elle recule de 1 jours jusqu’à arriver à -7 jours par rapport à la date actuelle. Et c’est là que j’ai besoin d’aide, je n’arrive pas à faire cohabiter les deux boucles. J’ai systématiquement un message disant qu’il manque Next.

Je m’excuse d’avance j’ai essayé plein de combinaisons possibles et du coup ma macro ne ressemble plus à rien (et j’ai pas réussi à la corriger). Il est aussi possible que certaines choses ne coïncident pas. En temps normal c’est un très gros fichier qui sert à plusieurs choses. J’ai dû le simplifier et changer des formules à l’extrême pour des raisons de confidentialité.

Voilà je ne sais pas si j’ai été assez clair, n’hésitez pas si vous avez des questions. Je ne pourrais pas me connecter du week-end par contre.

Bon week-end à tous et merci !

 

[Franc58]

Salut, teste ceci:

Sub TransfertRun()
    Application.ScreenUpdating = False

    Dim wsMacros As Worksheet, wsTransition As Worksheet
    Set wsMacros = Worksheets("Macros")
    Set wsTransition = Worksheets("Tableau transition")

    wsMacros.Visible = xlSheetVisible
    wsTransition.Visible = xlSheetVisible

    Dim DossierOriginal As String, DossierCopier As String, A_T As String
    Dim x As Integer, initialValue As Integer

    For L = 4 To 4003
        If wsTransition.Range("B" & L).Value = "AT" Then
            For x = 0 To -7 Step -1
                With wsTransition.Range("B" & L)
                    DossierOriginal = .Offset(0, 15).Value
                    DossierCopier = .Offset(0, 16).Value
                    A_T = .Offset(0, 17).Value
                End With

                If DossierExiste(DossierOriginal) = False Then
                    wsTransition.Range("B" & L).Offset(0, 18).Value = initialValue + x
                    If wsTransition.Range("B" & L).Offset(0, 18).Value = -8 Then
                        MsgBox ("Le run " & wsMacros.Range("B7").Value & " est introuvable")
                        wsMacros.Range("B2:B4").ClearContents
                        Exit For
                    End If
                End If

                If DossierExiste(DossierOriginal) = True And DossierExiste(DossierCopier) = True Then
                    MsgBox ("Le run " & wsMacros.Range("B5").Value & " a déjà été transféré")
                    wsMacros.Range("B2:B4").ClearContents
                ElseIf DossierExiste(DossierOriginal) = True And DossierExiste(DossierCopier) = False Then
                    MsgBox ("Le run " & wsMacros.Range("B5").Value & " a déjà été transféré")
                    wsMacros.Range("B2:B4").ClearContents
                ElseIf DossierExiste(DossierOriginal) = False And DossierExiste(DossierCopier) = False Then
                    Dim objFSO As Object 'copie et renomme le dossier modèle
                    Set objFSO = CreateObject("Scripting.FileSystemObject")
                    objFSO.CopyFolder DossierOriginal, DossierCopier, True

                    wsMacros.Range("B2:B7").ClearContents
                    wsTransition.Range("A" & A_T).Value = "X"
                End If
            Next x
        End If
    Next L

    wsMacros.Visible = xlSheetHidden
    wsTransition.Visible = xlSheetHidden

    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

 

[whiteshark]

Merci pour ta réponse ! Malheureusement ton code me renvoie systématiquement le message "le run a déjà été transféré".