Sujet Précédent Sujet Suivant

Comparaison de 2 liste Excel

Fermé
ju89 Messages postés 14 Date d'inscription samedi 13 septembre 2008 Statut Membre Dernière intervention 12 mars 2015 - Modifié par pijaku le 12/03/2015 à 08:01
f894009 Messages postés 17189 Date d'inscription dimanche 25 novembre 2007 Statut Membre Dernière intervention 6 mai 2024 - 13 mars 2015 à 08:04
Bonjour,

j'ai trouvé, pour les besoin d'un tableau excel, un bout de code que j'ai réussi à adapté à mon cas.

il s'agit de comparer 2 listes et de renvoyé les noms communs aux deux listes.
La dessus pas de soucis ça fonctionne bien.
Le soucis que j'ai est que si je retire des noms de la liste 2, ils restent tout de même affiché dans les nom commun alors qu'il ne sont plus commun aux 2 liste.

comment faire?

A noté que je n'y connais rien au VBA, j'ai fais de la bidouille a partir de code déjà existant.

voici mon code (trouvé ici: http://boisgontierjacques.free.fr/ ): 

Sub Communs()
Set f1 = Sheets("code")
Set f2 = Sheets("mars 2015")
Set mondico1 = CreateObject("Scripting.Dictionary")
For Each c In f1.Range("m5:m15" & f1.[m65000].End(xlUp).Row)
mondico1.Item(c.Value) = c.Value
Next c
Set mondico2 = CreateObject("Scripting.Dictionary")
For Each c In f2.Range("v3:V100" & f2.[d65000].End(xlUp).Row)
If mondico1.Exists(c.Value) Then If Not mondico2.Exists(c.Value) Then mondico2.Add c.Value, c.Value
Next c
Sheets("Mars 2015").[AB5].Resize(mondico2.Count, 1) = Application.Transpose(mondico2.items)
End Sub


Merci pour vos reponses




A voir également:

6 réponses

Réponse 1 / 6
Boisgontierjacques Messages postés 175 Date d'inscription jeudi 19 septembre 2013 Statut Membre Dernière intervention 26 décembre 2018 64
Modifié par Boisgontierjacques le 12/03/2015 à 21:13
Bonsoir,

Il suffit d'utiliser une fonction

http://boisgontierjacques.free.fr/fichiers/fonctionsperso/FonctionCommuns.xls

-Sélectionner un champ vertical
=Communs(champ1;champ2)
-Valider avec maj+ctrl+entrée

Function Communs(champ1, champ2)
Dim temp()
Set MonDico1 = CreateObject("Scripting.Dictionary")
For Each c In champ1
If Not MonDico1.Exists(c.Value) Then MonDico1.Add c.Value, c.Value
Next c
Set mondico2 = CreateObject("Scripting.Dictionary")
For Each c In champ2
If c <> "" And MonDico1.Exists(c.Value) Then
If Not mondico2.Exists(c.Value) Then mondico2.Add c.Value, c.Value
End If
Next c
i = 1
ReDim temp(1 To Application.Caller.Rows.Count)
i = 1
For Each c In mondico2.items
temp(i) = c
i = i + 1
Next
Communs = Application.Transpose(temp)
End Function


Jacques Boisgontier
1
f894009 Messages postés 17189 Date d'inscription dimanche 25 novembre 2007 Statut Membre Dernière intervention 6 mai 2024 1 705
13 mars 2015 à 08:04
Bonjour,

Merci de votre intervention, il est vrai que l'appelle de fonction est tres interessant et il est aussi vrai que je n'y pense pas souvent a cause du melange ecriture formule dans les cellules et code VBA
0
Réponse 2 / 6
f894009 Messages postés 17189 Date d'inscription dimanche 25 novembre 2007 Statut Membre Dernière intervention 6 mai 2024 1 705
Modifié par f894009 le 12/03/2015 à 09:00
Bonjour,

Ai modifie les deux lignes For Each (!!!!), ajoute code raz cellules infos communes 

Sub Communs()
    Set f1 = Sheets("code")
    Set f2 = Sheets("mars 2015")
    Set mondico1 = CreateObject("Scripting.Dictionary")
    For Each c In f1.Range("M5:M" & f1.[M65000].End(xlUp).Row)
        mondico1.Item(c.Value) = c.Value
    Next c
    Set mondico2 = CreateObject("Scripting.Dictionary")
    For Each c In f2.Range("V3:V" & f2.[V65000].End(xlUp).Row)
        If mondico1.Exists(c.Value) Then
            If Not mondico2.Exists(c.Value) Then
                mondico2.Add c.Value, c.Value
            End If
        End If
    Next c
    With f2
        'raz cellules colonne AB
        .Range("AB5:AB" & f2.[AB65000].End(xlUp).Row).ClearContents
        .[AB5].Resize(mondico2.Count, 1) = Application.Transpose(mondico2.items)
    End With
End Sub


A+
0
Réponse 3 / 6
ju89 Messages postés 14 Date d'inscription samedi 13 septembre 2008 Statut Membre Dernière intervention 12 mars 2015
12 mars 2015 à 10:21
salut f894009,

merci pour ta réponse, j'avais trouver la solution en effaçant la plage de cellule des nom commun et ca marche bien. Je vais utilisé ton code qui est mieux fais.
un autre soucis se pose:
si je n'ai plus aucun nom dans la liste f2 j'obtiens un erreur a niveau de la dernière ligne

.[AB5].Resize(mondico2.Count, 1) = Application.Transpose(mondico2.items)

je suppose que c'est parce qu'il n'y a plus rien a transposer. il faudrait lui dire que si il n'y a rien ba il fait rien. mais ça je ne sais pas faire en VBA.
0
Réponse 4 / 6
f894009 Messages postés 17189 Date d'inscription dimanche 25 novembre 2007 Statut Membre Dernière intervention 6 mai 2024 1 705
12 mars 2015 à 11:39
Re, 

Sub Communs()
    Set f1 = Sheets("code")
    Set f2 = Sheets("mars 2015")
    Set mondico1 = CreateObject("Scripting.Dictionary")
    For Each c In f1.Range("M5:M" & f1.[M65000].End(xlUp).Row)
        mondico1.Item(c.Value) = c.Value
    Next c
    Set mondico2 = CreateObject("Scripting.Dictionary")
    For Each c In f2.Range("V3:V" & f2.[V65000].End(xlUp).Row)
        If mondico1.Exists(c.Value) Then
            If Not mondico2.Exists(c.Value) Then
                mondico2.Add c.Value, c.Value
            End If
        End If
    Next c
    With f2
        'raz cellules colonne AB
        .Range("AB5:AB" & f2.[AB65000].End(xlUp).Row).ClearContents
        If mondico2.Count > 0 Then
            .[AB5].Resize(mondico2.Count, 1) = Application.Transpose(mondico2.items)
        Else
            MsgBox "Pas d'Infos communes dans les listes !!!!!"
        End If
    End With
End Sub
0

Vous n’avez pas trouvé la réponse que vous recherchez ?

Posez votre question
Réponse 5 / 6
ju89 Messages postés 14 Date d'inscription samedi 13 septembre 2008 Statut Membre Dernière intervention 12 mars 2015
12 mars 2015 à 11:59
Génial, merci, exactement ce que je voulais.

Maintenant je souhaiterai que cette macro soit toujours active. je l'ai donc placer dans le Worksheet_Change de la feuille. Mais j'ai un message d'erreur "sub attendu".

voici le code complet (j'ai enlevé ton Else, sinon le Msxbox s'afficherai a chaque fois que je modifie une cellule). 


Private Sub Worksheet_Change(ByVal Target As Range)

Sub Communs()
    Set f1 = Sheets("code")
    Set f2 = Sheets("mars 2015")
    Set mondico1 = CreateObject("Scripting.Dictionary")
    For Each c In f1.Range("M5:M" & f1.[M65000].End(xlUp).Row)
        mondico1.Item(c.Value) = c.Value
    Next c
    Set mondico2 = CreateObject("Scripting.Dictionary")
    For Each c In f2.Range("V3:V" & f2.[V65000].End(xlUp).Row)
        If mondico1.Exists(c.Value) Then
            If Not mondico2.Exists(c.Value) Then
                mondico2.Add c.Value, c.Value
            End If
        End If
    Next c
    With f2
        'raz cellules colonne AB
        .Range("AB5:AB" & f2.[AB65000].End(xlUp).Row).ClearContents
        If mondico2.Count > 0 Then
            .[AB5].Resize(mondico2.Count, 1) = Application.Transpose(mondico2.items)
        
        End If
    End With

        
        ActiveWorkbook.Worksheets(ActiveSheet.Name).Sort.SortFields.Clear
    ActiveWorkbook.Worksheets(ActiveSheet.Name).Sort.SortFields.Add Key:=Range("AB5") _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets(ActiveSheet.Name).Sort
        .SetRange Range("AB5:AB10")
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    
End Sub

End Sub
0
michel_m Messages postés 16603 Date d'inscription lundi 12 septembre 2005 Statut Contributeur Dernière intervention 16 décembre 2023 3 303
12 mars 2015 à 12:01
Bonjour
Enlève le sub communs et son end sub
0
ju89 Messages postés 14 Date d'inscription samedi 13 septembre 2008 Statut Membre Dernière intervention 12 mars 2015 > michel_m Messages postés 16603 Date d'inscription lundi 12 septembre 2005 Statut Contributeur Dernière intervention 16 décembre 2023
12 mars 2015 à 12:05
ça marche pas. la macro rentre dans une boucle interminable en faisant cela
0
Réponse 6 / 6
f894009 Messages postés 17189 Date d'inscription dimanche 25 novembre 2007 Statut Membre Dernière intervention 6 mai 2024 1 705
12 mars 2015 à 12:31
Re,

code dans VBA feuille "mars 2015" je suppose. Si ok, je vous metterai des lignes de commentaires 

Private Sub Worksheet_Change(ByVal Target As Range)
    der = [V65000].End(xlUp).Row
    If Not Application.Intersect(Target, Range("V3:V" & der)) Is Nothing Then
        Application.ScreenUpdating = False
        Application.EnableEvents = False
        Set f1 = Sheets("code")
        Set f2 = Sheets("mars 2015")
        Set mondico1 = CreateObject("Scripting.Dictionary")
        der = f1.[M65000].End(xlUp).Row
        For Each c In f1.Range("M5:M" & der)
            mondico1.Item(c.Value) = c.Value
        Next c
        Set mondico2 = CreateObject("Scripting.Dictionary")
        der = f2.[V65000].End(xlUp).Row
        For Each c In f2.Range("V3:V" & der)
            If mondico1.Exists(c.Value) Then
                If Not mondico2.Exists(c.Value) Then
                    mondico2.Add c.Value, c.Value
                End If
            End If
        Next c
        With f2
            'raz cellules colonne AB
            .Range("AB5:AB" & f2.[AB65000].End(xlUp).Row).ClearContents
            If mondico2.Count > 0 Then
                .[AB5].Resize(mondico2.Count, 1) = Application.Transpose(mondico2.items)
            End If
        End With
        
        ActiveWorkbook.Worksheets(ActiveSheet.Name).Sort.SortFields.Clear
        ActiveWorkbook.Worksheets(ActiveSheet.Name).Sort.SortFields.Add Key:=Range("AB5") _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        With ActiveWorkbook.Worksheets(ActiveSheet.Name).Sort
            .SetRange Range("AB5:AB" & f2.[AB65000].End(xlUp).Row)
            .Header = xlNo
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
    End If
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub
0
ju89 Messages postés 14 Date d'inscription samedi 13 septembre 2008 Statut Membre Dernière intervention 12 mars 2015
12 mars 2015 à 12:45
oui en effet vous supposez bien. on peut même mettre 

Set f2 = Sheets(ActiveSheet.Name)


car c'est une feuille que je vais devoir dupliquer tout les mois
0
ju89 Messages postés 14 Date d'inscription samedi 13 septembre 2008 Statut Membre Dernière intervention 12 mars 2015
12 mars 2015 à 13:10
En revanche certain nom ne disparaissent plus quand je les supprime de la liste f2, alors que ça fonctionnait très avec le code précédent.
0
f894009 Messages postés 17189 Date d'inscription dimanche 25 novembre 2007 Statut Membre Dernière intervention 6 mai 2024 1 705 > ju89 Messages postés 14 Date d'inscription samedi 13 septembre 2008 Statut Membre Dernière intervention 12 mars 2015
12 mars 2015 à 13:34
Re,

avant ou apres Set f2 = Sheets(ActiveSheet.Name)
0
ju89 Messages postés 14 Date d'inscription samedi 13 septembre 2008 Statut Membre Dernière intervention 12 mars 2015
12 mars 2015 à 13:43
avant
0
f894009 Messages postés 17189 Date d'inscription dimanche 25 novembre 2007 Statut Membre Dernière intervention 6 mai 2024 1 705 > ju89 Messages postés 14 Date d'inscription samedi 13 septembre 2008 Statut Membre Dernière intervention 12 mars 2015
12 mars 2015 à 13:50
Re,

Chez moi, ca marche !!!!

code modifie pour duplication feuille: 
Private Sub Worksheet_Change(ByVal Target As Range)
    On Error GoTo traite_erreur
    
    der = [V65000].End(xlUp).Row
    If Not Application.Intersect(Target, Range("V3:V" & der)) Is Nothing Then
        Application.ScreenUpdating = False
        Application.EnableEvents = False
        Set f1 = Sheets("code")
        Set mondico1 = CreateObject("Scripting.Dictionary")
        der = f1.[M65000].End(xlUp).Row
        For Each c In f1.Range("M5:M" & der)
            mondico1.Item(c.Value) = c.Value
        Next c
        Set mondico2 = CreateObject("Scripting.Dictionary")
        der = [V65000].End(xlUp).Row
        For Each c In Range("V3:V" & der)
            If mondico1.Exists(c.Value) Then
                If Not mondico2.Exists(c.Value) Then
                    mondico2.Add c.Value, c.Value
                End If
            End If
        Next c
        'raz cellules colonne AB
        Range("AB5:AB" & [AB65000].End(xlUp).Row).ClearContents
        If mondico2.Count > 0 Then
            [AB5].Resize(mondico2.Count, 1) = Application.Transpose(mondico2.items)
        End If
        
        ActiveWorkbook.Worksheets(ActiveSheet.Name).Sort.SortFields.Clear
        ActiveWorkbook.Worksheets(ActiveSheet.Name).Sort.SortFields.Add Key:=Range("AB5") _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        With ActiveWorkbook.Worksheets(ActiveSheet.Name).Sort
            .SetRange Range("AB5:AB" & [AB65000].End(xlUp).Row)
            .Header = xlNo
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
    End If
traite_erreur:
    Application.ScreenUpdating = True
    Application.EnableEvents = True

End Sub
0

Discussions similaires

Suppression listes déroulantes
Archa -
Sam -

5 réponses