Comment effectuer une action pour chaque valeur présente dans une liste ?

Bonjour, je suis en stage dans une entreprise et on m'as demandé d'automatiser une gestion de fichier. Cependant je fait face a une incompréhension.

Je souhaiterais définir ma variable principale "TierPartner" pour chaque valeur recensée dans la liste. Cependant après plusieurs échecs infructueux je suis bloqué sur un code qui ne fait que la première valeur de la liste en boucle.

Mon code est le suivant :

Sub FiltrerEtCopierDonnees()
Dim TierPartner As Variant
Dim classeur510 As Workbook
Dim nomFichier As String
Dim cheminBureau As String
Dim cheminDossierTest As String
Dim cheminComplet As String
Dim nouvelleFeuille As Worksheet
Dim feuilleForm As Worksheet
Dim feuilleInfo1 As Worksheet
Dim plageCopie As Range
Dim plageCollage As Range
Dim plageFiltre As Range
Dim derniereLigne As Long
Dim colonnes As String
Dim colonnesBleues As Range
Dim colonneVerte As Range
Dim feuilleGL As Worksheet
Dim feuilleInfo2 As Worksheet
Dim rng As Range
Dim cell As Range
Dim dict As Object
Dim num As Variant
Dim position As Long

' La construction de ma liste :

Set feuilleForm = ThisWorkbook.Sheets("Form")
Set rng = feuilleForm.Range("C1:C" & feuilleForm.Cells(feuilleForm.Rows.Count, "C").End(xlUp).Row)
Set dict = CreateObject("Scripting.Dictionary")
For Each cell In rng
If IsNumeric(cell.Value) Then
num = cell.Value
If Not dict.exists(num) Then
dict.Add num, Nothing
End If
End If
Next cell

' Ma fonction Do dans laquelle je souhaite appliquer chaque valeur de la liste :

Do
TierPartner = num
Set classeur510 = Workbooks.Add
Set feuilleInfo1 = classeur510.Sheets.Add(After:=classeur510.Sheets(classeur510.Sheets.Count))
feuilleInfo1.Name = "FORM"
Set feuille = classeur510.Sheets("FORM")
Set colonnesBleues = feuille.Range("B:B, C:C, D:D, E:E, F:F, G:G, I:I, K:K")
Set colonneVerte = feuille.Range("J:J")
colonnesBleues.Font.Color = RGB(0, 0, 255)
colonneVerte.Font.Color = RGB(0, 128, 0)
Set feuilleForm = ThisWorkbook.Sheets("form")
feuilleForm.Range("A1:M200").AutoFilter Field:=3, Criteria1:=TierPartner
Set plageFiltree = feuilleForm.Range("A1:M200").SpecialCells(xlCellTypeVisible)
plageFiltree.Copy
Set plageCollage = classeur510.Sheets("FORM").Range("A8")
plageCollage.PasteSpecial Paste:=xlPasteValues
feuilleForm.AutoFilterMode = False
Set feuilleForm = ThisWorkbook.Sheets("Form")
Set feuilleInfo1 = classeur510.Sheets("FORM")
Set plageCopie = feuilleForm.Range("A1:M8")
Set plageCollage = feuilleInfo1.Range("A1")
plageCopie.Copy Destination:=plageCollage
Set feuilleForm = ThisWorkbook.Sheets("Form")
Set feuilleInfo1 = classeur510.Sheets("FORM")
derniereLigne = feuilleInfo1.Cells(Rows.Count, 1).End(xlUp).Row
Set plageCopie = feuilleForm.Range("A41:M43")
Set plageCollage = feuilleInfo1.Cells(derniereLigne + 1, 1)
plageCopie.Copy Destination:=plageCollage
Set feuille = classeur510.Sheets("FORM")
derniereLigne = feuille.Cells(Rows.Count, 2).End(xlUp).Row
Set plage = feuille.Range("A1:M" & derniereLigne)
For Each cellule In plage.Columns(2).Cells
If Not IsEmpty(cellule) Then
feuille.Range("A" & cellule.Row & ", M" & cellule.Row).Interior.Color = RGB(255, 255, 153)
End If
Next cellule
Columns("H:H").EntireColumn.AutoFit
Set feuilleInfo1 = classeur510.Sheets.Add(After:=classeur510.Sheets(classeur510.Sheets.Count))
feuilleInfo1.Name = "Info"

Set feuilleGL = ThisWorkbook.Sheets("GL")
Set feuilleInfo2 = classeur510.Sheets("Info")
feuilleGL.AutoFilterMode = False
feuilleGL.Range("A1:M200").AutoFilter Field:=4, Criteria1:=TierPartner
derniereLigne = feuilleGL.Cells(feuilleGL.Rows.Count, 1).End(xlUp).Row
Set plageFiltre = feuilleGL.Range("A1:M" & derniereLigne).SpecialCells(xlCellTypeVisible)
plageFiltre.Copy
feuilleInfo2.Range("A1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
feuilleGL.AutoFilterMode = False
Application.CutCopyMode = False
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
classeur510.Sheets("Feuil1").Delete
Application.ScreenUpdating = True
Application.DisplayAlerts = True

nomFichier = TierPartner & ".xlsx"
Set classeur510 = ThisWorkbook
cheminBureau = CreateObject("WScript.Shell").SpecialFolders("Desktop")
cheminDossierTest = cheminBureau & "\TEST"
cheminComplet = cheminDossierTest & "\" & nomFichier
ActiveWorkbook.SaveAs cheminComplet
ActiveWorkbook.Close

Edit modo : code à mettre entre balises avec le bouton </> merci d'y faire attention la prochaine fois

L'endroit ou je pense devoir ajouter de quoi passer a la valeur suivante de la liste mais je trouve pas

Loop

End Sub

Désolé si le fichier est dégueu, j'suis pas du tout un pro en VBA ahah

et merci d'avance a ceux qui prendront le temps de m'aider

Bonjour Loumatrix,

N'hésitez pas à utiliser :

Et mettre votre code à l'intérieur pour que ça soit plus lisible à lire pour tout le monde ^^

Autant pour moi désolé, un modo l'as gentillement fait

Concernant votre problème, c'est que vous définissez la valeur de TierPartner en dehors de la boucle, donc elle ne change jamais. De plus, vous avez construit un dictionnaire dict avec vos numéros uniques, mais vous ne l'utilisez pas dans votre boucle. Vous devez utiliser ce dictionnaire pour générer vos différentes valeurs de TierPartner.

Un exemple de comment faire :

' Créer un tableau avec les clés de votre dictionnaire
Dim keys() As Variant
keys = dict.keys

' Parcourir le tableau des clés
For Each num In keys

    ' Utiliser la valeur courante de num comme valeur pour TierPartner
    TierPartner = num

    ' Le reste de votre code utilise cette valeur de TierPartner

Next num

Dans votre cas, remplacez votre Do par For Each num In keys et supprimez Loop à la fin du code. Le code entre For Each num In keys et Next num sera exécuté pour chaque valeur unique dans votre plage de cellules. J'espere que cela vous aidera ! ^^

merci beaucoup !