XL 2010 Modification de code pour y intéger une condition

Fils de Coulson

XLDnaute Nouveau
Bonjour à tous,
J'ai une macro qui sert à extraire des données sans doublons d'une feuille sur une autre :
VB:
Sub SansDoublonsTrie_SAP()
Dim MonDico As Object
Dim c As Range

Set MonDico = CreateObject("Scripting.Dictionary")
With Worksheets("Rapport 1")
     For Each c In .Range("A2:A" & .Cells(.Rows.Count, 1).End(xlUp).Row)
         If Not MonDico.exists(Trim(c.Value)) Then MonDico.Add Trim(c.Value), Trim(c.Value)
     Next c
     With Sheets("Activités terminées").Range("A3").Resize(MonDico.Count, 1)
         .Value = Application.Transpose(MonDico.keys)
         .Sort Key1:=Worksheets("Activités terminées").Range("A3"), Order1:=xlAscending, Header:=xlNo
     End With
End With
Set MonDico = Nothing
End Sub
auquel j'aimerais rajouter une condition.
La condition est la suivante : si la plage nommée "Etat_de_l_activité" est égal à 2.

Merci par avance de bien vouloir m'aiguiller.
Bonne journée.
 

job75

XLDnaute Barbatruc
Alors qu'est-ce qui doit être égal à 2 ? La 1ère cellule ou toutes les cellules ?

Si c'est la 1ère cellule utilisez :
VB:
If TypeName([Etat_de_l_activité]) <> "Range" Then Exit Sub
If CStr([Etat_de_l_activité].Cells(1)) <> "2" Then Exit Sub
 
Dernière édition:

Fils de Coulson

XLDnaute Nouveau
Bonjour job75, le forum,
Désolé pour cette réponse tardive.
Même en rajoutant tes lignes de codes, je n'arrive pas à obtenir ce que je souhaite.
Je vais essayer d'anonymiser mes données et posté un fichier : je pense que ce sera plus parlant.
Merci en attendant. Bonne journée.
 

Fils de Coulson

XLDnaute Nouveau
Bonjour job75, le forum,
Voici le fichier anonymisé avec la macro d'origine.
Je voudrais que les lignes surlignées en rouge dans l'onglet "Activités terminées" soient exclues de l'extraction afin de ne garder que les données dont les activités sont au statut "2" (colonne L dans l'onglet "Rapport 1").
Voilà, en espérant avoir été plus explicite.
Merci par avance et bonne journée.
 

Pièces jointes

  • Classeur1.xlsm
    216.5 KB · Affichages: 3

job75

XLDnaute Barbatruc
Bonjour Fils de Coulson,

Avec le fichier le problème aurait été réglé immédiatement il y a une semaine :
VB:
Sub SansDoublonsTrie_SAP()
Dim MonDico As Object, c As Range
Set MonDico = CreateObject("Scripting.Dictionary")
With Worksheets("Rapport 1")
     For Each c In .Range("A2:A" & .Cells(.Rows.Count, 1).End(xlUp).Row)
         If c(1, 12) = 2 Then MonDico(Trim(c.Value)) = ""
     Next c
End With
With Sheets("Activités terminées").Range("A3")
    If MonDico.Count Then
        With .Resize(MonDico.Count)
            .Value = Application.Transpose(MonDico.keys)
            .Sort Key1:=.Columns(1), Order1:=xlAscending, Header:=xlNo
        End With
    End If
    .Offset(MonDico.Count).Resize(Rows.Count - MonDico.Count - .Row + 1).ClearContents 'RAZ en dessous
End With
End Sub
A+
 

Discussions similaires

Réponses
12
Affichages
250

Statistiques des forums

Discussions
312 211
Messages
2 086 299
Membres
103 172
dernier inscrit
Aurelyan