Résultat avec un critère dans un array, est-ce possible ?

**RyuAutodidacte** · 09/10/2018, 23h24

Bonsoir jpvba,

Tu peux aussi relire le post de @Transistoire qui resume bien les conditions dans lesquelles le code doit s'effectuer

Je te donne un lien pour exemple d'un code que j'ai fait, mais attention celui-ci utilise les filtres directement sur des nouveaux classeurs alors que toi tu dois l'effectuer sur des feuilles.
Ce qui veut dire que avant d'effectuer tes filtres, tu dois vérifier si la feuille existe (Ex : "ONTPQ"); dans le cas où elle n'existe pas, il faut la créer. Après tu peux y effectuer ton filtre et ainsi de suite pour chaque établissements
donc faire attention au code dans la boucle
Voilà le lien si cela peut t'inspirer dans la démarche, mais attention tu devras adapter à ta situation, ce qui veut dire ne pas faire du copier-coller mais comprendre le principe pour l'adapter :
https://www.developpez.net/forums/d1.../#post10522864

Edit : relis ce post où je parle de la feuille tampon et tout le reste :
https://www.developpez.net/forums/d1.../#post10518474

**jpvba** · 10/10/2018, 16h19

Bonjour a vous

Pour le

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

As-tu lu le billet VBA – CodeName d’une feuille Excel que je t'ai conseillé de lire ?

Environ 8 fois avant d'utiliser le codename et présentement 2 fois

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
Il est évident que pour faciliter la compréhension de la lecture d’un code, il est préférable de modifier la valeur du CodeName.
L’exemple ci-dessous est plus lisible avec shtRecap qu’avec Feuil1
 
 
shtRecap.Range("A1").Value = "Date"
1
shtRecap.Range("A1").Value = "Date"
Cette modification s’effectue manuellement dans la fenêtre des propriétés mais peut évidemment se faire à l’aide du code VBA.

Je sais que je peux le faire le façon manuel et de façon VBA (ton billet n'indique pas comment faire en vba, j'ai dû fouillé sur d'autre site web pour comment changer le codename)

Dans l'exemple on utilise le nom du codename au lieu de sheets("nomdelafeuille") et dans mon code la même chose mais j'ai un erreur ... est-ce dû fait que j'utilise l'option explicite ??? De mémoire j'ai déjà utiliser le codename et j'Avais non plus ce message d'erreur. Je me réfère donc a vous pourquoi le code ne fonctionne pas

Pour le tutoriel, je l'ai lu 20 fois minimum ... en lisant je ne focus pas nécessairement les petits détails ... il est donc important que je "vie" la situation, ce que je fais présentement. Pour moi j'apprends la logique et le fais de ne pas le vivre est moins ancré dans ma mémoire. La théorie est bonne mais la pratique pour moi est la solution pour apprendre une logique. UN média qui utilise plusieurs sens tel que le video est plus compréhensible pour moi qu'un texte. Avoir un "feedback" en temps réel est également plus compréhensible qu'un vidéo, mais c'Est mon cerveau qui fonctionne ainsi.

Je suis très visuel et j'apprends de cette façon ... je lis effectivement tous les commentaires mais étant donné que c'Est du texte brut, parfois j'échappe ce que l'on veux me dire. En me citant à la feuille de référence dans la bonne section effectivement je comprends le "bug" mais c'Est parce que je l'ai vécu. J'ai lu la logique j'applique la logique et lorsque je frappe à quelque chose d'illogique c'Est là que je frappe un mur même si c'est par exemple dans 8 pages de texte que j'ai lu 50 fois.

Je me fais un "scénario" dans ma tête et en le vivant, je m'adapte et la prochaine fois je sais par où passé. C'Est le pourquoi que je continue a codé malgré que j'ai un résultat vraiment rapide avec le code que Ryu a posté. J'utilise vous, mes sources de savoir et de connaissance, a fin d'évoluer dans ce langage dont plusieurs méprises mais que son utilisation est géniale.

merci encore pour votre transfert de savoir et connaissances

amicalement JP

**RyuAutodidacte** · 10/10/2018, 16h48

Re

Oublie le codename pour l'instant, tu auras tou le temps pour l'utiliser par la suite
Tu as besoin juste de 2 feuilles supplémentaires, une pour les paramètres et une pour réceptionner les données et une fois réceptionnée dans ledit feuille il faudra juste faire un copier coller dans la feuille concernée

1 - à faire manuellement : créer une feuille pour les paramètres en A1 tu copie colle l'en-tête des établissements puis sur la même ligne en E1 et F1 tu copies l'en-tête pour les paramètres établissements et les x - cf mes captures dans un de mes post
2 - à faire manuellement : créer une feuille réceptrice des données avec sur la 1 ère lignes toutes les entête dont tu as besoin - ct tjs capture dans mon post
Fais cela déjà, je re pour la suite

**jpvba** · 10/10/2018, 17h16

Super, je continue ...

petite question blitz, pourquoi une feuille "paramètre" à part, pourquoi ne pas mettre les donnée dans la feuille initiale (travail) qui est une copie (copie de R_MoulinetteAValider) ???

**RyuAutodidacte** · 10/10/2018, 17h23

Envoyé par jpvba

Super, je continue ...

petite question blitz, pourquoi une feuille "paramètre" à part, pourquoi ne pas mettre les donnée dans la feuille initiale (travail) qui est une copie (copie de R_MoulinetteAValider) ???

Il n'y a pas besoin d'une copie de la base de données, car on y touchera pas

**Philippe Tulliez** · 10/10/2018, 17h27

Bonjour,

pourquoi une feuille "paramètre" à part, pourquoi ne pas mettre les donnée dans la feuille initiale (travail)

Les deux cas donneront le même résultat. Cependant si les critères sont placés dans la feuille source, il faudra juste ne pas oublier d'effacer la zone des critères avant de terminer la procédure.
Proposer tout les cas possibles aurait nécessité plus de littérature et il me semble que c'est déjà assez compliqué comme cela.

En général, j'utilise comme zone des critères les cellules des lignes 1 et 2 de la deuxième colonne située à droite de la dernière colonne de la donnée source et j'utilise les critères calculés (autre cas encore)

**Philippe Tulliez** · 10/10/2018, 18h04

Bonjour,
Avant de commencer avec un projet complexe, il faut comprendre le principe de la méthode AdvancedFilter (filtre avancé)

Prenons un premier exemple avec un classeur comprenant trois feuilles

[Source] une petite base de données de trois colonnes et 6 lignes
[Cible] la feuille où aura lieu l'exportation
[Param] la feuille où l'on place la zone des critères

Le code ci-dessous exporte toutes les colonnes de la plage de données se trouvant en feuille [Source] (plage A1:C7) vers la cellule A1 de la feuille [cible] en fonction du critère se trouvant en cellule A1:A2 de la feuille nommée [Param]

Nom : AdvancedFilter - Exemple_1.png
Affichages : 106
Taille : 21,3 Ko

Nom : AdvancedFilter - Exemple_1.png
Affichages : 106
Taille : 21,3 Ko

Le code

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
Sub Exemple_1()
  ' Déclaraion des variables
  Dim rngSource As Range   ' Plage source
  Dim rngTarget As Range   ' Plage cible
  Dim rngCriteria As Range ' Plage des critères
  ' Assignatation des valeurs aux variables
  With ThisWorkbook
    Set rngSource = .Worksheets("data").Range("A1").CurrentRegion
    Set rngTarget = .Worksheets("cible").Range("A1")
    Set rngCriteria = .Worksheets("Param").Range("A1:A2")
  End With
  ' Efface les cellules de la feuille d'exportation
  rngTarget.Worksheet.Cells.Clear
  rngSource.AdvancedFilter xlFilterCopy, rngCriteria, rngTarget
  ' Fin
  Set rngSource = Nothing: Set rngCriteria = Nothing: Set rngTarget = Nothing
End Sub

Je te propose de modifier ensuite la valeur de la cellule A2 de la feuille [Param] et relancer la procédure et constater par toi même.
Ensuite, tu ajoutes en feuille Param

cellule B1 le titre Export
cellule B2 la lettre X

Tu modifies ensuite la ligne 10 du code du dessus comme l'exemple ci-dessous

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Set rngCriteria = .Worksheets("Param").Range("A1:B2")

et tu relances le code

Une fois que tu auras bien compris, j'envoie l'exemple 2 où on fera l'exportation avec deux critères dont la deuxième partie sera le résultat de la liste unique de Case

**RyuAutodidacte** · 10/10/2018, 18h26

Re

On va faire cela par décomposition

Première chose : la première partie du code va être la création des établissements en unique via les filtres élaboré. Cela peut être fait en utilisant l'enregistreur de macro :
Dans l'enregistreur de macro :
– sélection de la feuille paramètres
- utilisation du filtre élaboré avec coche de copie et unique sur la colonne des établissements

Ensuite dans une nouvelle sub on va juste faire une boucle For Each dans la feuille paramètres sur les établissements.
Le fait de pouvoir boucler sur chaque établissements, permettra d'alimenter la zone de critère

**jpvba** · 10/10/2018, 20h04

Voici donc ce que j'ai a présent.

Ma feuille de donnée est R_MoulinetteAValider, que j'ai copié sous le nom de "travail". Dans le "travail", j'ai effectué les filtres élaborés. Donc "travail" est ma donné source et de critère.

Je suis rendu à l'étape des boucles, et créé les onglets uniques. J'ai deux possibilité sois créé les onglets et apres les remplir ou les créés et remplir en meme temps

Si j'ai omis quelquechose ou sauter des étapes SVP m'Aviser ... j'ai eu énormément d'information ...

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
Sub genere_onglets_etablissement_filtre_elab()
 
'On Error GoTo errorhandler:
 
    Dim x As Long
    Dim LettreVoulue As String
 
    Dim nom_etablissement As Variant
    Dim start As Single
    Dim finish As Single
 
    start = Timer
 
    Application.ScreenUpdating = False
 
    If sheetExists("R_MoulinetteAValider") = False Then
    MsgBox "Erreur d'exécution, feuille R_MoulinetteAValider manquante", vbCritical
    Exit Sub
    End If
 
    Application.DisplayAlerts = False
 
    If sheetExists("travail") = True Then
    Sheets("travail").Delete
    Else
    End If
 
    Application.DisplayAlerts = True
 
'nettoie le nom des etablissements provenant du LAC afin d'éviter d'avoir 2 onglets
 
    LettreVoulue = TrouveLettreColonne([acronyme_etab])
    Range(LettreVoulue & 2, LettreVoulue & LastLignUsedInSheet("R_MoulinetteAValider")).Select
    Selection.Replace What:=Chr(47), Replacement:=Chr(32)
    Selection.Replace What:=Chr(92), Replacement:=Chr(32)
    Selection.Replace What:=Chr(91), Replacement:=Chr(32)
    Selection.Replace What:=Chr(93), Replacement:=Chr(32)
    nettoyerseul
 
'création d'une copie de la feuille afin de garder les information pour plus tard
 
Sheets("R_MoulinetteAValider").Copy Before:=Sheets("R_MoulinetteAValider")
ActiveSheet.Name = "travail"
 
     With Sheets("R_MoulinetteAValider")
 
        With Union(.Range(.Range(TrouveLettreColonne([ID_titre]) & 1), .Range(TrouveLettreColonne([prix_contrat_titre]) & 1)), _
        .Range(.Range(TrouveLettreColonne([valider_etablissement_titre]) & 1), .Range(TrouveLettreColonne([commentaire_etablissement_titre]) & 1)))
            With .Copy
                With Sheets("travail").Range("bA1")
                .PasteSpecial Paste:=xlPasteColumnWidths
                .PasteSpecial Paste:=xlPasteFormats
                .PasteSpecial Paste:=xlPasteValues
                End With
                With Sheets("travail").Range("bu1")
                .PasteSpecial Paste:=xlPasteColumnWidths
                .PasteSpecial Paste:=xlPasteFormats
                .PasteSpecial Paste:=xlPasteValues
                End With
            End With
        End With
    End With
 
    Range("Ba2").CurrentRegion.Name = "plage_result1"
    Range("BU2").CurrentRegion.Name = "plage_result2"
    Range("a2").CurrentRegion.Name = "plage_debut"
 
 Range("av1").value = Sheets("R_MoulinetteAValider").[valider_etablissement_titre].value
 Range("av2").value = "X"
 Range("aw1").value = Sheets("R_MoulinetteAValider").[acronyme_etab_titre].value
 Range("av1:av2").Name = "critere_1"
 
   Application.DisplayAlerts = False
   Range("plage_debut").AdvancedFilter Action:=xlFilterCopy, criteriarange:= _
   Range("critere_1"), CopyToRange:=Range("plage_result1"), Unique:=False
 
Range("BE1:BE" & LastLignUsedInColumn("be")).AdvancedFilter Action:=xlFilterCopy, criteriarange:=Empty, CopyToRange:=Range( _
        "AW1:AW2"), Unique:=True
 
Range("av2:av" & LastLignUsedInColumn("AW")).value = "x"
 
Range("av2").CurrentRegion.Name = "critere_2"
 
 
Application.DisplayAlerts = True
 
finish = Timer
 
MsgBox "durée du traitement: " & finish - start & " secondes"
 
Exit Sub
 
errorhandler:
MsgBox "Erreur d'exécution, la procédure va se terminer !", vbCritical
 
 
End Sub

merci les amis vraiment tres éducatif !!!

Edit

Apres avoir exécuter d'autre sub je vois que le fais d'avoir copier R_MoulinetteAValider en travail, le gestionnaire de noms est bousiller donc je me répond un peu moi même avec l'expérience que j ne devrais pas copier le fichier source afin d'en faire ma feuille de filtre.

**RyuAutodidacte** · 10/10/2018, 21h14

Re,

J'ai deux possibilité sois créé les onglets et apres les remplir ou les créés et remplir en meme temps

Le choix que j'avais fait de mon coté est de vérifier si la feuille Existe; dans le cas où elle n'existe pas je la créé.
Pourquoi … tout simplement pcq dans le cas où tu relance le code et que tu as de nouveaux établissements, on pourra créer automatiquement la/les nouvelle(s) feuille(s) et y envoyer les données
Pour les feuilles existantes on y envoie directement les données

Edit : Sur la base du fichier que tu m'avais fournis voilà le fichier de départ :
fichier debut resultat.xlsx
C'est la base pour commencer les 2 feuilles (Liste_Filtre et F_Receptrice (dont un reste de test

)) ont été faites manuellement

Edit 2 : je t'avais fourni une fonction pour vérifier si la feuille existe, tu peux t'en servir

Edit 3 : on peut servir du même fichier pour faire les mêmes manip et codes

Edit 4: la feuille des critères "Liste_Filtre" (fichier envoyé) - ce que j'ai au début :

AcronyKe étab				AcronyKe étab	À valider - Établissements
					x

Le but obtenir la liste unique des établissements via le filtre avancé (étape 1)
on obtient ceci :

AcronyKe étab	AcronyKe étab	À valider - Établissements
CHOKPQ 03-05		x
ONTPQ
CEWEP T-R
CHORQEVSOX
3-ROVOERET
PSKKEROOE
THETFSRD
WOCEQ
BEQQEVPE
BEOPCE
H-WOTPETOE
KONWONOE

étape 2 on boucle via une boucle For each sur la feuille "Liste_Filtre" de A2 jusqu'à la dernière ligne non vide

• Lors du 1er passage de la boucle on vérifie si la feuille CHOKPQ 03-05 Existe

- Cas 1 : elle existe on continue le code

- Cas 2 : elle n'existe pas on créé la feuille - on pourra se servir de la feuille réceptrice "F_Receptrice pour copier les en-têtes directement sur la feuille créée

Ensuite on copie le critère (on est toujours dans la boucle - je fais une capture moins grande pour la place)
on obtient ceci :

AcronyKe étab	AcronyKe étab	À valider - Établissements
CHOKPQ 03-05	CHOKPQ 03-05	x
ONTPQ
CEWEP T-R

Grâce aux critères en E1:F2 sur la feuille "Liste_Filtre" on va pouvoir faire son filtre avancé sur la feuille réceptrice "F_Receptrice" (pratique cela nous fera toujours le même paramètres)
Souvient de ce que à dit @Transitoire :

… chaque nouvelle extraction, excel efface toutes les données présente sous la zone et ce jusqu'au bas de la page, pour les remplacer par les nouvelles données extraites.

Comme on aura au préalable mis la variable du nom de la feuille que l'on peut appeler Nom_Feuille par exemple,
pour chaque passage de la boucle (après la vérification si la feuille existe et une éventuelle création de celle-ci)
on pourra alors pointé la copie sur la feuille Nom_Feuille à partir de la 1ère ligne vide via les données obtenu du filtre avancé sur la feuille F_Receptrice

une fois fais on passera au prochain établissement :

AcronyKe étab	AcronyKe étab	À valider - Établissements
CHOKPQ 03-05	ONTPQ
ONTPQ
CEWEP T-R

PS : en-têtes que l'on a fait manuellement sur F_Receptrice lors de la préparation de base - on va se servir de cela pour faire l'ensemble des filtres avancés pour chaque établissements :

ID

Séq

Pair Impair

Étab

AcronyKe étab

Item Étab Moulinette

Item Établissement

Description Établissement

Couleur Établissement

Fournisseur Établissement

Fournisseur LAC

Marque Établissement

Catalogue Établissement

Format contrat Établissement

Qté annuelle requise

Prix à contrat Établissement

À valider - Établissements

Commentaire du GACEQ - Questions aux établissements

Reponse de l'etablissement

Donc reprenons depuis le début. Pour commencer la macro l'un des critères est de connaitre les établissments (besoin d'un liste unique - sans doublons),
et le 2è critères est un x dans la colonne "À valider - Établissements" (cette condition est rempli au préalable lorsque que nous avons créer les 2 feuilles manuellement Liste_Filtre et F_Receptrice.

=> Enregistreur de Macro (on se met sur la feuille Liste_Filtre) => Filtre avancé … => pour création d'une liste unique d'établissements (étape 1)

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
Sub Macro1()
'
' Macro1 Macro
 
    Application.CutCopyMode = False
    Application.CutCopyMode = False
    Range("acronyme_etab").AdvancedFilter Action:=xlFilterCopy, CopyToRange:= _
        Range("A1"), Unique:=True
End Sub

on nettoie la macro :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
Sub Macro1()
    Range("acronyme_etab").AdvancedFilter Action:=xlFilterCopy, CopyToRange:= _
        Sheets("Liste_Filtre").Range("A1"), Unique:=True 'on ajoute la feuille pour qu'il n'y est pas d’équivoque sur l'appartenance de la plage A1
End Sub

Mais ce qui m'intéresse, c'est de faire un pointage indirect de la plage A1 sur la feuille Liste_Filtre, car sait on jamais d'autres éléments du code pourrait aussi pointer sur ledit feuille :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
Sub Macro1_OK()
    With Sheets("Liste_Filtre")
        Range("acronyme_etab").AdvancedFilter Action:=xlFilterCopy, CopyToRange:= _
            .Range("A1"), Unique:=True ' le point "." devant Range permet de faire rérérence à l'objet feuille nommé "Liste_Filtre"
        End With
End Sub
' L’instruction With/End With permet d’exécuter de manière simplifiée plusieurs actions sur un objet.
' L’instruction With / End With permet de faire référence qu’une seule fois à un objet au lieu de le répéter à chaque action.

1ère partie terminé

Passons à la boucle : Cette boucle va se faire sur la liste unique se trouvant de A2 jusqu'à la dernière ligne non vide de la feuille Liste_Filtre
pour connaître/créer la feuille, copier le critère (afin de faire le filtre avancé)
=> Sheets("Liste_Filtre").Range("A2:A" & .Cells(.Rows.Count, 1).End(xlUp).Row) => utilisons un For Each … Next
On aura besoin de connaître le nom de l'établissement pour le critère et le nom de la feuille établissement

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
Sub Boucle()
Dim Nom_Etab As String, Acro As Range
 
    With Sheets("Liste_Filtre")
        For Each Acro In .Range("A2:A" & .Cells(.Rows.Count, 1).End(xlUp).Row)
            Nom_Etab = Acro.Value
            MsgBox Nom_Etab
            .Range("E2").Value = Nom_Etab
        Next
    End With
End Sub

Tiens on peut se servir du With avec la même feuille !!
Faire le code en pas à pas pour voir ce que l'on fait …
Du coup je vais pourvoir commencer à agrémenter mon code (Attention on a pas encore fait la vérification de l'existence de la feuille + ce qui doit suivre)

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
Sub Filtre_Etab()
Dim Nom_Etab As String, Acro As Range
 
    With Sheets("Liste_Filtre")
 
        Range("acronyme_etab").AdvancedFilter Action:=xlFilterCopy, CopyToRange:= _
            .Range("A1"), Unique:=True
 
        For Each Acro In .Range("A2:A" & .Cells(.Rows.Count, 1).End(xlUp).Row)
            Nom_Etab = Acro.Value
            MsgBox Nom_Etab
            .Range("E2").Value = Nom_Etab
            ' … suite du code à faire
        Next
 
    End With
End Sub

**jpvba** · 11/10/2018, 22h36

Salut encore a vous mes amis !!!

JE suis présentement rendu à

- Cas 2 : elle n'existe pas on créé la feuille - on pourra se servir de la feuille réceptrice "F_Receptrice pour copier les en-têtes directement sur la feuille créée

J'ai fais a présent le même principe que ce que j'ai fait dans ma sub de base i.e., détruire tous les onglets lorsque l'on régénère la macro. Alors, je crée l'entête en même temps que la feuille et l'importation des données

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
Sub genere_onglets_etablissement_filtre_elab_3()
 
'On Error GoTo errorhandler:
 
 
    Dim LettreVoulue As String
 
    Dim nom_etablissement As Variant
    Dim start As Single
    Dim finish As Single
    Dim etab_x As Variant
 
 
    start = Timer
 
    Application.ScreenUpdating = False
 
    If sheetExists("R_MoulinetteAValider") = False Then
    MsgBox "Erreur d'exécution, feuille R_MoulinetteAValider manquante", vbCritical
    Exit Sub
    End If
 
    Application.DisplayAlerts = False
 
    If sheetExists("param") = True Then
    Sheets("param").Delete
    Else
    End If
 
 Sheets("R_MoulinetteAValider").Activate
 
    LettreVoulue = TrouveLettreColonne([acronyme_etab])
    For Each nom_etablissement In Sheets("R_MoulinetteAValider").Range(LettreVoulue & 2, LettreVoulue & LastLignUsedInColumn(LettreVoulue))
 
 
 
                If sheetExists(nom_etablissement.value) = False Then
 
 
                Else
                   Sheets(nom_etablissement.value).Delete
 
                End If
 
    Next nom_etablissement
 
'nettoie le nom des etablissements provenant du LAC afin d'éviter d'avoir 2 onglets
    Sheets("R_MoulinetteAValider").Select
    LettreVoulue = TrouveLettreColonne([acronyme_etab])
    Sheets("R_MoulinetteAValider").Range(LettreVoulue & 2, LettreVoulue & LastLignUsedInSheet("R_MoulinetteAValider")).Select
    Selection.Replace What:=Chr(47), Replacement:=Chr(32)
    Selection.Replace What:=Chr(92), Replacement:=Chr(32)
    Selection.Replace What:=Chr(91), Replacement:=Chr(32)
    Selection.Replace What:=Chr(93), Replacement:=Chr(32)
    nettoyerseul
 
 
'nommer la plage de début
 
 Sheets("R_MoulinetteAValider").Range("a2").CurrentRegion.Name = "plage_debut"
 
'création de la feuille de param (feuille de paramêtre)
 
 Sheets.Add.Name = "param"
 
 With Sheets("R_MoulinetteAValider")
 
        With Union(.Range(.Range(TrouveLettreColonne([ID_titre]) & 1), .Range(TrouveLettreColonne([prix_contrat_titre]) & 1)), _
        .Range(.Range(TrouveLettreColonne([valider_etablissement_titre]) & 1), .Range(TrouveLettreColonne([commentaire_etablissement_titre]) & 1)))
            With .Copy
                With Sheets("param").Range("i1")
                .PasteSpecial Paste:=xlPasteColumnWidths
                .PasteSpecial Paste:=xlPasteFormats
                .PasteSpecial Paste:=xlPasteValues
                End With
            End With
        End With
    End With
 
 
 Sheets("param").Range("a1").value = Sheets("R_MoulinetteAValider").[acronyme_etab_titre].value
 Sheets("param").Range("d1").value = Sheets("R_MoulinetteAValider").[acronyme_etab_titre].value
 
 Sheets("param").Range("e1").value = Sheets("R_MoulinetteAValider").[valider_etablissement_titre].value
 Sheets("param").Range("e2").value = "X"
 Sheets("param").Range("d2").CurrentRegion.Name = "critere_1"
 Sheets("param").Range("i2").CurrentRegion.Name = "receptrice"
 
 Sheets("R_MoulinetteAValider").Range("plage_debut").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:= _
        Range("critere_1"), CopyToRange:=Sheets("param").Range("A1:A2"), Unique:=True
 
 
 Sheets("param").Range("a2:a" & LastLignUsedInColumn("a")).Name = "critere_2"
 
 
 For Each etab_x In [critere_2]
 
 
   If sheetExists(etab_x) = True Then
    Else
   Sheets.Add.Name = etab_x
     With ActiveSheet.Tab
      .ThemeColor = xlThemeColorAccent3
      .TintAndShade = 0.399975585192419
   Sheets("param").Range("d2") = etab_x
 
   Sheets("R_MoulinetteAValider").Range("plage_debut").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:= _
        Range("critere_1"), CopyToRange:=Sheets("param").Range("receptrice"), Unique:=False
 
   Sheets("param").Range("i1:z" & LastLignUsedInSheet_Column("param", "i")).Copy Sheets(etab_x.value).Range("a1")
     End With
   End If
 Next etab_x
 
 
Sheets("param").Delete
 
Application.DisplayAlerts = True
 
finish = Timer
 
MsgBox "durée du traitement: " & finish - start & " secondes"
 
Exit Sub
 
errorhandler:
MsgBox "Erreur d'exécution, la procédure va se terminer !", vbCritical
 
 
End Sub

JE vais continuer les étapes que tu m'as indiquer afin d'apprendre également la méthode prescrite !!!

Les imprimes écrans de ton dernier poste, Ryu m'a fait réaliser que je m'était compliqué la vie pour la feuille de critère !!!

Je progresse !! et re poste des que je termine les autres étapes !!!

**RyuAutodidacte** · 12/10/2018, 01h05

Re,

Pourquoi détruire les onglets ? afin de tester et de ne pas le faire manuellement ??

• Pour moi au tout tout 1er lancement de la macro les onglets établissement n'existe pas.
Donc ils sont créer automatiquement avec la macro

• Au 2ème lancement de la macro, on efface pas les onglets, on vérifie qu'ils existent
et dans le cas d'un nouvel établissement, on créé son onglet (donc ajouter avec les autres)

Les imprimes écrans de ton dernier poste, Ryu m'a fait réaliser que je m'était compliqué la vie pour la feuille de critère !!!

Cela simplifie aussi le code et c'est le cas aussi pour la feuille réceptrice dont on envoie le résultat pour chaque filtre avancé de chaque établissement

Que gagne t'on avec F_Receptrice, fait manuellement … … :

=> Faire son filtre avancé pour tous les établissements directement dessus (simplification …)
=> Copie direct de l'en-tête sur tous les nouveaux onglets (copie colle y a pas plus simple -> simplification du code)
=> Copie direct du résultat du filtre avancé sur l'onglet établissement correspondant (copie colle y a pas plus simple -> simplification du code)

On réduit bien le code en plus de le simplifier …

**jpvba** · 12/10/2018, 16h33

Bonjour Ryu,

Pourquoi détruire les onglets ? afin de tester et de ne pas le faire manuellement ??

A cette question, je répond au cas ou que les gens re-lance le code une seconde fois suite a une modification au niveau de la question et ou de la poser ou pas. C'Est un peu pourquoi dans ce scénario que j'ai fais ainsi. Le cas de retrait d'une question, je n'ai pas le choix de prendre tous les fournisseurs possbiles et non ceux de la liste restrainte. MAis effectivement je risque de prendre ta solution avec le changement du "x" par un autre mot afin de ne pas regénéré. Disons, j'ai amusé mon cerveau a terminé ce code selon mon code originale. Chacune des deux possiblités (celle-ci et la tiennes) comporte des avantages et inconvénients. LE changement de question pour une meme ligne ne ce corrige pas avec ta façon parcontre elle est plus lente que la tienne.

JE continué a bidouillé comme vous le dite mes chèrs amis.

Je vous tiens au courant de mes progrès !!!

**RyuAutodidacte** · 12/10/2018, 17h26

Re,

A cette question, je répond au cas ou que les gens re-lance le code une seconde fois suite a une modification au niveau de la question et ou de la poser ou pas. C'Est un peu pourquoi dans ce scénario que j'ai fais ainsi. Le cas de retrait d'une question, je n'ai pas le choix de prendre tous les fournisseurs possbiles et non ceux de la liste restrainte.

Avant de coder et jeter ses mains et sa tête dans le cambouis, il faut savoir s'arrêter afin de résoudre les nouvelles problématiques en évitant de tout chambouler quand la base du processus est solide.

A quoi cela sert d'avoir un ID censé être unique permettant de "Matcher" sur ce que l'on veut ????
Une simple formule de RECHERCHEV ou INDEX EQUIV suffit à mettre à jour les informations dans la colonne choisie … …

LE changement de question pour une meme ligne ne ce corrige pas avec ta façon parcontre elle est plus lente que la tienne.

Évidemment, cela n'à jamais fait l'objet de la problématique du post et n'a jamais été évoqué jusqu'à présent

**jpvba** · 12/10/2018, 17h48

Bonjour Ryu,

Effectivement on peut pallier ou plutôt corriger le problème avec le "id" qui est effectivement unique a chacune des lignes.

LE pourquoi que j'en ai pas parlé dans le post, ta solution que tu m'as présenté je la trouve vraiment géniale, plus rapide, plus logique. Le cas où que la

re-génération est une correction de la bête humaine ... je me fis donc au conseil de notre ami Pierre Fauconnier de ne pas utilisé du code VBA pour pallier a des lacunes (dans le cas où que c'est possible). Dans cette situation, je peux effectivement faire autrement avec mes gens. La chance que les gens modifient les questions est tres faible donc a mon avis, pas besoin de vouloir généré les exceptions.

Étant donné le "retrait" de cette situation, j'ai donc omis de l'indiqué.

L'avoir terminé me permet 2 choses, me pratiquer et pouvoir comparer les 2 codes en terme de temps d'exécution et de complexité.

merci encore beaucoup pour es interventions, conseils et ton temps ... vraiment apprécié !!!

amicalement JP

**RyuAutodidacte** · 12/10/2018, 17h59

As tu fait le code dans la logique tel indiqué dans les explications du Post #70

Quel serait la suite du code (à faire en commentaires) TEXTUELLEMENT ??? - cf ci-dessous :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
Sub Filtre_Etab()
Dim Nom_Etab As String, Acro As Range
 
    With Sheets("Liste_Filtre")
 
        Range("acronyme_etab").AdvancedFilter Action:=xlFilterCopy, CopyToRange:= _
            .Range("A1"), Unique:=True
 
        For Each Acro In .Range("A2:A" & .Cells(.Rows.Count, 1).End(xlUp).Row)
            Nom_Etab = Acro.Value
            MsgBox Nom_Etab
            .Range("E2").Value = Nom_Etab
            ' … mettre les commentaires ici (une ligne = une action)
            ' … suite … etc …
        Next
 
    End With
End Sub

Si tu veux bien … ? A moins que le post soit

**jpvba** · 12/10/2018, 19h33

Je suis en train de, mon cher ami ...

Si je ne me fais pas déranger par d'autre chose, je suis supposé d'y jeter un coup d'oeil

JE suis rendu à la même endroit que le poste #71

je te tiens alors au courant des questionnement/probleme ou si j'ai terminé le code en question.

**jpvba** · 22/10/2018, 19h47

Je suis rendu ici

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
Sub genere_onglets_etablissement_filtre_elab_6()
 
'On Error GoTo errorhandler:
 
 
    Dim LettreVoulue As String
 
    Dim start As Single
    Dim finish As Single
    Dim etab_x As Variant
    Dim Acro As Range
    Dim Nom_Etab As String
 
    start = Timer
 
'    Application.ScreenUpdating = False
 
    If sheetExists("R_MoulinetteAValider") = False Then
    MsgBox "Erreur d'exécution, feuille R_MoulinetteAValider manquante", vbCritical
    Exit Sub
    End If
 
    Application.DisplayAlerts = False
 
    If sheetExists("param") = True Then
    Sheets("param").Delete
    Else
    End If
 
   If sheetExists("travail") = True Then
   Sheets("travail").Delete
   Else
   End If
 
'nettoie le nom des etablissements provenant du LAC afin d'éviter d'avoir 2 onglets
    Sheets("R_MoulinetteAValider").Select
    LettreVoulue = TrouveLettreColonne([acronyme_etab])
    Sheets("R_MoulinetteAValider").Range(LettreVoulue & 2, LettreVoulue & LastLignUsedInSheet("R_MoulinetteAValider")).Select
    Selection.Replace What:=Chr(47), Replacement:=Chr(32)
    Selection.Replace What:=Chr(92), Replacement:=Chr(32)
    Selection.Replace What:=Chr(91), Replacement:=Chr(32)
    Selection.Replace What:=Chr(93), Replacement:=Chr(32)
    nettoyerseul
 
 
'nommer la plage de début
 
 Sheets("R_MoulinetteAValider").Range("a2").CurrentRegion.Name = "plage_debut"
 
'création de la feuille travail (feuille receptrice)
 
 Sheets.Add.Name = "travail"
 
 With Sheets("R_MoulinetteAValider")
 
        With Union(.Range(.Range(TrouveLettreColonne([ID_titre]) & 1), .Range(TrouveLettreColonne([prix_contrat_titre]) & 1)), _
        .Range(.Range(TrouveLettreColonne([valider_etablissement_titre]) & 1), .Range(TrouveLettreColonne([commentaire_etablissement_titre]) & 1)))
            With .Copy
                With Sheets("travail").Range("a1")
                .PasteSpecial Paste:=xlPasteColumnWidths
                .PasteSpecial Paste:=xlPasteFormats
                .PasteSpecial Paste:=xlPasteValues
                End With
            End With
        End With
    End With
 
'création de la feuille de param (feuille de paramêtre)
Sheets.Add.Name = "param"
 
 Sheets("travail").Range("a2").CurrentRegion.Name = "receptrice"
 
 
 
 
 With Sheets("param")
 
 .Range("a1").value = Sheets("R_MoulinetteAValider").[acronyme_etab_titre].value
 .Range("d1").value = Sheets("R_MoulinetteAValider").[acronyme_etab_titre].value
 
 .Range("e1").value = Sheets("R_MoulinetteAValider").[valider_etablissement_titre].value
 .Range("e2").value = "X"
 .Range("d2").CurrentRegion.Name = "critere_1"
 .Range("a2:a" & LastLignUsedInColumn("a")).Name = "critere_2"
 
        Sheets("R_MoulinetteAValider").Range("plage_debut").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:= _
        Sheets("param").Range("critere_1"), CopyToRange:=Sheets("param").Range("A1:A2"), Unique:=True
 
        For Each Acro In .Range("A2:A" & .Cells(.Rows.Count, 1).End(xlUp).Row)
            Nom_Etab = Acro.value
            MsgBox Nom_Etab
            .Range("D2").value = Nom_Etab
        Next Acro
 
 End With
 
 
 
Application.DisplayAlerts = True
 
finish = Timer
 
MsgBox "durée du traitement: " & finish - start & " secondes"
 
Exit Sub
 
errorhandler:
MsgBox "Erreur d'exécution, la procédure va se terminer !", vbCritical
 
 
End Sub

Edit 1. si je fait la boucle

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
Sub genere_onglets_etablissement_filtre_elab_5()
 
'On Error GoTo errorhandler:
 
 
    Dim LettreVoulue As String
 
    Dim start As Single
    Dim finish As Single
    Dim etab_x As Variant
 
    start = Timer
 
'    Application.ScreenUpdating = False
 
    If sheetExists("R_MoulinetteAValider") = False Then
    MsgBox "Erreur d'exécution, feuille R_MoulinetteAValider manquante", vbCritical
    Exit Sub
    End If
 
    Application.DisplayAlerts = False
 
    If sheetExists("param") = True Then
    Sheets("param").Delete
    Else
    End If
 
   If sheetExists("travail") = True Then
   Sheets("travail").Delete
   Else
   End If
 
'nettoie le nom des etablissements provenant du LAC afin d'éviter d'avoir 2 onglets
    Sheets("R_MoulinetteAValider").Select
    LettreVoulue = TrouveLettreColonne([acronyme_etab])
    Sheets("R_MoulinetteAValider").Range(LettreVoulue & 2, LettreVoulue & LastLignUsedInSheet("R_MoulinetteAValider")).Select
    Selection.Replace What:=Chr(47), Replacement:=Chr(32)
    Selection.Replace What:=Chr(92), Replacement:=Chr(32)
    Selection.Replace What:=Chr(91), Replacement:=Chr(32)
    Selection.Replace What:=Chr(93), Replacement:=Chr(32)
    nettoyerseul
 
 
'nommer la plage de début
 
 Sheets("R_MoulinetteAValider").Range("a2").CurrentRegion.Name = "plage_debut"
 
'création de la feuille travail (feuille receptrice)
 
 Sheets.Add.Name = "travail"
 
 With Sheets("R_MoulinetteAValider")
 
        With Union(.Range(.Range(TrouveLettreColonne([ID_titre]) & 1), .Range(TrouveLettreColonne([prix_contrat_titre]) & 1)), _
        .Range(.Range(TrouveLettreColonne([valider_etablissement_titre]) & 1), .Range(TrouveLettreColonne([commentaire_etablissement_titre]) & 1)))
            With .Copy
                With Sheets("travail").Range("a1")
                .PasteSpecial Paste:=xlPasteColumnWidths
                .PasteSpecial Paste:=xlPasteFormats
                .PasteSpecial Paste:=xlPasteValues
                End With
            End With
        End With
    End With
 
'création de la feuille de param (feuille de paramêtre)
Sheets.Add.Name = "param"
 
 With Sheets("param")
 
 .Range("a1").value = Sheets("R_MoulinetteAValider").[acronyme_etab_titre].value
 .Range("d1").value = Sheets("R_MoulinetteAValider").[acronyme_etab_titre].value
 
 .Range("e1").value = Sheets("R_MoulinetteAValider").[valider_etablissement_titre].value
 .Range("e2").value = "X"
 .Range("d2").CurrentRegion.Name = "critere_1"
 
 End With
 
 Sheets("travail").Range("a2").CurrentRegion.Name = "receptrice"
 
 Sheets("R_MoulinetteAValider").Range("plage_debut").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:= _
        Sheets("param").Range("critere_1"), CopyToRange:=Sheets("param").Range("A1:A2"), Unique:=True
 
 
 Sheets("param").Range("a2:a" & LastLignUsedInColumn("a")).Name = "critere_2"
 
 
 For Each etab_x In Sheets("param").[critere_2]
 
 
   If sheetExists(etab_x.value) = True Then
    Else
   Sheets.Add.Name = etab_x
 
     With ActiveSheet.Tab
      .ThemeColor = xlThemeColorAccent3
      .TintAndShade = 0.399975585192419
     End With
 
  Sheets("travail").Range("a1").CurrentRegion.Copy Sheets(etab_x.value).Range("a1")
 
 
  Sheets("param").Range("d2") = etab_x
 
 
 
 
   End If
 
 Next etab_x
 
Application.DisplayAlerts = True
 
finish = Timer
 
MsgBox "durée du traitement: " & finish - start & " secondes"
 
Exit Sub
 
errorhandler:
MsgBox "Erreur d'exécution, la procédure va se terminer !", vbCritical
 
 
End Sub

**jpvba** · 22/10/2018, 20h34

Bonjour a vous,

JE comprends le principe du filtre élaborée, de validée si la feuille existe sinon la créer avec l'entete ...

Ce qui me manque comme notion c'est le fameux principe que si la feuille est existante, ont ajouté apres la dernière ligne la nouvelle information, tel que du as ait dans ton code.

merci beaucoup les gars !!!!

Pour info le code avec filtre élaborée

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
Sub genere_onglets_etablissement_filtre_elab_4()
 
On Error GoTo errorhandler:
 
 
    Dim LettreVoulue As String
 
    Dim nom_etablissement As Variant
    Dim start As Single
    Dim finish As Single
    Dim etab_x As Variant
 
    start = Timer
 
'    Application.ScreenUpdating = False
 
    If sheetExists("R_MoulinetteAValider") = False Then
    MsgBox "Erreur d'exécution, feuille R_MoulinetteAValider manquante", vbCritical
    Exit Sub
    End If
 
    Application.DisplayAlerts = False
 
    If sheetExists("param") = True Then
    Sheets("param").Delete
    Else
    End If
 
 
'nettoie le nom des etablissements provenant du LAC afin d'éviter d'avoir 2 onglets
    Sheets("R_MoulinetteAValider").Select
    LettreVoulue = TrouveLettreColonne([acronyme_etab])
    Sheets("R_MoulinetteAValider").Range(LettreVoulue & 2, LettreVoulue & LastLignUsedInSheet("R_MoulinetteAValider")).Select
    Selection.Replace What:=Chr(47), Replacement:=Chr(32)
    Selection.Replace What:=Chr(92), Replacement:=Chr(32)
    Selection.Replace What:=Chr(91), Replacement:=Chr(32)
    Selection.Replace What:=Chr(93), Replacement:=Chr(32)
    nettoyerseul
 
 
'nommer la plage de début
 
 Sheets("R_MoulinetteAValider").Range("a2").CurrentRegion.Name = "plage_debut"
 
'création de la feuille de param (feuille de paramêtre)
 
 Sheets.Add.Name = "param"
 
 With Sheets("R_MoulinetteAValider")
 
        With Union(.Range(.Range(TrouveLettreColonne([ID_titre]) & 1), .Range(TrouveLettreColonne([prix_contrat_titre]) & 1)), _
        .Range(.Range(TrouveLettreColonne([valider_etablissement_titre]) & 1), .Range(TrouveLettreColonne([commentaire_etablissement_titre]) & 1)))
            With .Copy
                With Sheets("param").Range("i1")
                .PasteSpecial Paste:=xlPasteColumnWidths
                .PasteSpecial Paste:=xlPasteFormats
                .PasteSpecial Paste:=xlPasteValues
                End With
            End With
        End With
    End With
 
 With Sheets("param")
 
 .Range("a1").value = Sheets("R_MoulinetteAValider").[acronyme_etab_titre].value
 .Range("d1").value = Sheets("R_MoulinetteAValider").[acronyme_etab_titre].value
 
 .Range("e1").value = Sheets("R_MoulinetteAValider").[valider_etablissement_titre].value
 .Range("e2").value = "X"
 .Range("d2").CurrentRegion.Name = "critere_1"
 .Range("i2").CurrentRegion.Name = "receptrice"
End With
 
 Sheets("R_MoulinetteAValider").Range("plage_debut").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:= _
        Sheets("param").Range("critere_1"), CopyToRange:=Sheets("param").Range("A1:A2"), Unique:=True
 
 
 Sheets("param").Range("a2:a" & LastLignUsedInColumn("a")).Name = "critere_2"
 
 
 For Each etab_x In Sheets("param").[critere_2]
 
 
   If sheetExists(etab_x) = True Then
    Else
   Sheets.Add.Name = etab_x
 
     With ActiveSheet.Tab
      .ThemeColor = xlThemeColorAccent3
      .TintAndShade = 0.399975585192419
     End With
 
   With Sheets("R_MoulinetteAValider")
 
        With Union(.Range(.Range(TrouveLettreColonne([ID_titre]) & 1), .Range(TrouveLettreColonne([prix_contrat_titre]) & 1)), _
        .Range(.Range(TrouveLettreColonne([valider_etablissement_titre]) & 1), .Range(TrouveLettreColonne([commentaire_etablissement_titre]) & 1)))
            With .Copy
                With Sheets(etab_x.value).Range("a1")
                .PasteSpecial Paste:=xlPasteColumnWidths
                .PasteSpecial Paste:=xlPasteFormats
                .PasteSpecial Paste:=xlPasteValues
                End With
            End With
        End With
    End With
 
 
 
   Sheets("param").Range("d2") = etab_x
 
   Sheets("R_MoulinetteAValider").Range("plage_debut").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:= _
        Range("critere_1"), CopyToRange:=Sheets("param").Range("receptrice"), Unique:=False
 
 
   Sheets("param").Range("i1:z" & LastLignUsedInSheet_Column("param", "i")).Copy Sheets(etab_x.value).Range("a1")
 
   Sheets("param").Range("i2:z" & LastLignUsedInSheet_Column("param", "i")) = Empty
 
   End If
 
 Next etab_x
 
Application.DisplayAlerts = True
 
finish = Timer
 
MsgBox "durée du traitement: " & finish - start & " secondes"
 
Exit Sub
 
errorhandler:
MsgBox "Erreur d'exécution, la procédure va se terminer !", vbCritical
 
 
End Sub

**RyuAutodidacte** · 24/10/2018, 12h29

Bonjour @jpvba,

PS : Concernant tes codes, pas testé car il y a pleins de fonctions manquantes …

Quel serait la suite du code (à faire en commentaires) TEXTUELLEMENT ???

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
Sub Filtre_Etab()
Dim Nom_Etab As String, Acro As Range
 
    With Sheets("Liste_Filtre")
 
        Range("acronyme_etab").AdvancedFilter Action:=xlFilterCopy, CopyToRange:= _
            .Range("A1"), Unique:=True
 
        For Each Acro In .Range("A2:A" & .Cells(.Rows.Count, 1).End(xlUp).Row)
            Nom_Etab = Acro.Value
            MsgBox Nom_Etab
            .Range("E2").Value = Nom_Etab
            ' … mettre les commentaires ici (une ligne = une action)
            ' … suite … etc …
        Next
 
    End With
End Sub

je n'ai pas vu la suite des commentaires montrant les différentes actions qui suivent (juste des commentaires, pas de code)
Cela permet de voir le cheminement afin de faire le code correctement avec les bonnes actions et dans le bon ordre …

Petite correction sur la logique du code concernant les établissements à traiter; en fait il ne faut pas répertorier tous les établissements en liste unique,
mais seulement les établissements en liste unique et qui comportent un "x" dans la colonne "À valider - Établissements"

Dans la feuille "Liste_Filtre" :

AcronyKe étab				AcronyKe étab	À valider - Établissements
					x

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
Sub Macro2_OK()
    With Sheets("Liste_Filtre")
        Sheets("depart").Cells(1).CurrentRegion.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=.Range("F1:F2"), _
                CopyToRange:=.Range("A1"), Unique:=True  ' le point "." devant Range permet de faire rérérence à l'objet feuille nommé "Liste_Filtre"
        ' L’instruction With/End With permet d’exécuter de manière simplifiée plusieurs actions sur un objet.
        ' L’instruction With / End With permet de faire référence qu’une seule fois à un objet au lieu de le répéter à chaque action.
    End With
End Sub