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 16904 Date d'inscription dimanche 25 novembre 2007 Statut Membre Dernière intervention 18 mars 2023 - 13 mars 2015 à 08:04
f894009 Messages postés 16904 Date d'inscription dimanche 25 novembre 2007 Statut Membre Dernière intervention 18 mars 2023 - 13 mars 2015 à 08:04
A voir également:
- Comparaison de 2 liste Excel
- Liste déroulante excel - Guide
- Formule excel - Guide
- 2 comptes whatsapp - Guide
- Supprimer liste déroulante excel ✓ - Forum Excel
- Déplacer une colonne excel - Guide
6 réponses
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
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
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
f894009
Messages postés
16904
Date d'inscription
dimanche 25 novembre 2007
Statut
Membre
Dernière intervention
18 mars 2023
1 678
Modifié par f894009 le 12/03/2015 à 09:00
Modifié par f894009 le 12/03/2015 à 09:00
Bonjour,
Ai modifie les deux lignes For Each (!!!!), ajoute code raz cellules infos communes
A+
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+
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
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.
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.
f894009
Messages postés
16904
Date d'inscription
dimanche 25 novembre 2007
Statut
Membre
Dernière intervention
18 mars 2023
1 678
12 mars 2015 à 11:39
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
Vous n’avez pas trouvé la réponse que vous recherchez ?
Posez votre question
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
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).
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
michel_m
Messages postés
16593
Date d'inscription
lundi 12 septembre 2005
Statut
Contributeur
Dernière intervention
7 mars 2023
3 291
12 mars 2015 à 12:01
12 mars 2015 à 12:01
Bonjour
Enlève le sub communs et son end sub
Enlève le sub communs et son end sub
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
16593
Date d'inscription
lundi 12 septembre 2005
Statut
Contributeur
Dernière intervention
7 mars 2023
12 mars 2015 à 12:05
12 mars 2015 à 12:05
ça marche pas. la macro rentre dans une boucle interminable en faisant cela
f894009
Messages postés
16904
Date d'inscription
dimanche 25 novembre 2007
Statut
Membre
Dernière intervention
18 mars 2023
1 678
12 mars 2015 à 12:31
12 mars 2015 à 12:31
Re,
code dans VBA feuille "mars 2015" je suppose. Si ok, je vous metterai des lignes de commentaires
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
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
12 mars 2015 à 12:45
oui en effet vous supposez bien. on peut même mettre
car c'est une feuille que je vais devoir dupliquer tout les mois
Set f2 = Sheets(ActiveSheet.Name)
car c'est une feuille que je vais devoir dupliquer tout les mois
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
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.
f894009
Messages postés
16904
Date d'inscription
dimanche 25 novembre 2007
Statut
Membre
Dernière intervention
18 mars 2023
1 678
>
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
12 mars 2015 à 13:34
Re,
avant ou apres Set f2 = Sheets(ActiveSheet.Name)
avant ou apres Set f2 = Sheets(ActiveSheet.Name)
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
12 mars 2015 à 13:43
avant
f894009
Messages postés
16904
Date d'inscription
dimanche 25 novembre 2007
Statut
Membre
Dernière intervention
18 mars 2023
1 678
>
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
12 mars 2015 à 13:50
Re,
Chez moi, ca marche !!!!
code modifie pour duplication feuille:
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
13 mars 2015 à 08:04
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