Pb Macro de Tri

Version imprimable

1 pièce(s) jointe(s)

Pb Macro de Tri

Bonjour,

J'ai réalisé une macro pour les tri de données, je m'explique :
Dans la feuille Administration, j'ai une liste de personnes avec 5 colonnes de données ;
Dans la feuille Web, j'ai une liste de personnes avec 4 colonnes de données ;
Dans la feuille Resultat, je voudrais voir apparaitre la liste des personne qui sont dans la feuille Web mais qui ne sont pas dans la liste de la feuille Administration (avec l'ensemble des informations s'y rapportant (5 colonnes).

Je pensais que ma macro (Macro1) fonctionnait or je m’aperçois que cela ne va pas : exemple Mlle Corbelle et Passy figure dans la liste de la feuille Resultat.

Quelqu'un aurait il une idées, une remarque ou un conseil ? SVP Merci

Voici le code de la macro :
Code:

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 Sub Macro1() Dim plgA As Range, plgB As Range, c As Range Dim listA(), listB() Dim i As Integer, x As Integer, col As Integer Dim a As String, b As String, champ As Variant, sp As Variant Set plgA = Sheets("Administration").Range("A2:A" & Sheets("Administration").Range("A65536").End(xlUp).Row) Set plgB = Sheets("web").Range("A2:A" & Sheets("web").Range("A65536").End(xlUp).Row) col = Sheets("Administration").Range("IV1").End(xlToLeft).Column For Each c In plgA 'CONCATENER chaque cellule Colonne 1 à 4 de chaqu'une des lignes des tableau A et B ' et renseigne les listA et lisB, pour éviter les doublons For i = 1 To col a = a & "," & Sheets("Administration").Cells(c.Row, i) b = b & "," & Sheets("web").Cells(c.Row, i) Next ReDim Preserve listA(x) listA(x) = Right(a, Len(a) - 1) a = "" ReDim Preserve listB(x) listB(x) = Right(b, Len(b) - 1) b = "" x = x + 1 Next 'vérifier si chaque item(champ) de listA est présente dans listB 'si non présente mets l'information sur la feuille résultat en commencant à la 'ligne 2 x = 2 For Each champ In listA() If champ = Empty Then Exit Sub If IsError(Application.Match(champ, listB, 0)) Then sp = Split(champ, ",") For i = 0 To col - 1 Sheets("résultat").Cells(x, i + 1) = sp(i) Next x = x + 1 End If Next
Ci joint le fichier exemple
Raphael

08/04/2012, 15h27
Philippe Tulliez

Bonjour,
Avant de joindre un fichier dans ton premier message, affiche plutôt le code de ta macro entre les balises prévues à cet effet.
09/04/2012, 08h44
Philippe Tulliez

Bonjour,
Ton erreur vient de la ligne 34

Code:

If IsError(Application.Match(champ, listB, 0)) Then

Tu utilises la fonction Match qui est la fonction VBA qui simule la fonction (Equiv/Match) de recherche Excel donc qui doit être utilisée sur une plage de cellules (1 colonne ou 1 ligne).
Sa syntaxe complète est Application.WorksheetFunction.Match
Extrait de l'aide en ligne

Citation:

Renvoie la position relative d'un élément dans une matrice (matrice : permet de créer des formules uniques permettant d’obtenir plusieurs résultats et qui agissent sur un groupe d’arguments répartis dans des lignes et des colonnes. Une plage matricielle partage une même formule tandis qu’une constante matricielle est un groupe de constantes qui sert d’argument.), qui correspond à une valeur spécifiée dans un ordre spécifié. Utilisez la fonction MATCH au lieu de l'une des fonctions LOOKUP lorsque vous avez besoin de la position d'un élément dans une plage au lieu de l'élément proprement dit.

Or, tu fais une recherche sur la variable tableau listB et pas sur une plage de cellules. Il y a donc incompatibilité et tu aura toujours une erreur.
09/04/2012, 09h31
Raphaelphp

Prob de macro de tri

Merci pour cette explication.

Aurais tu une solution pour obtenir le résultat (comparaison des deux listes et affichage des infos n'existant que dans une) que je souhaite ? SVP Merci

Raphaël

Bonjour,

Voici une solution.
A la lecture de tes explications, j’ai compris qu’il fallait comparer les données des 5 premières colonnes de la feuille Administration avec les 5 premières colonnes de la feuille Web et qu’il fallait inscrire dans la feuille résultat la liste des personne qui sont dans la feuille Administration mais qui ne sont pas dans la feuille Web, avec l'ensemble des informations s'y rapportant (6 colonnes).

Code:

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
Option Explicit
Sub Macro1()
Dim plgA As Range, plgB As Range, c As Range, Cel As Range
Dim Idem As Boolean
Dim i As Byte
Dim LigneAjout As Long
    Set plgA = Sheets("Administration").Range("A2:A" & Sheets("Administration").Range("A65536").End(xlUp).Row)
    Set plgB = Sheets("web").Range("A2:A" & Sheets("web").Range("A65536").End(xlUp).Row)
    Sheets("résultat").Range("A1").CurrentRegion.Offset(1, 0).ClearContents
    For Each Cel In plgA
        Idem = False
        Set c = plgB.Find(Cel.Value, LookIn:=xlValues)
        If Not c Is Nothing Then
            Idem = True
            For i = 1 To 4
                If c.Offset(0, i) <> Cel.Offset(0, i) Then Idem = False
            Next i
        End If
        If Not Idem Then
            LigneAjout = Sheets("résultat").Range("A65536").End(xlUp).Row + 1
            Cel.Resize(, 6).Copy Destination:=Sheets("résultat").Range("A" & LigneAjout)
        End If
        Set c = Nothing
    Next Cel
    Set plgA = Nothing
    Set plgB = Nothing
End Sub

Cordialement.

09/04/2012, 14h17
Raphaelphp

1 pièce(s) jointe(s)

Macro Tri

Bonjour,

Merci pour ta reponse mais cela ne semble pas fonctionner :

Par exemple je ne devrais pas retrouver
Corbel
Lagarde
Passy

dans la page resultats pourtant je les retrouve.

Je ne comprends pas pourquoi ?

As tu une idée

Ci joint mon fichier

SVP Merci

Raphael

Bonjour,

Pour Corbel et Passy, c’est justifié car les adresses sont différentes :
Dans Administration, Corbel Angélique habite 1 RUE MICHAEL ANGE alors que dans web elle habite 1 RUE MICHEL ANGE.
Dans Administration, Passy Frédérique habite 9 RUE NARCISSE AUSSENARD alors que dans web elle habite 9 RUE NARCISSE AUSSENARD LE GRAND MESNIL.
Par contre, pour Lagarde Raphael c’est un dysfonctionnement. Le programme autorise la copie parce qu’il a trouvé un autre Lagarde qui est différent (Lagarde Audrey).
J’ai modifié le code pour que la copie ne soit effectuée que dans le cas où aucun équivalent n’a été trouvé dans la feuille web.
Essaie avec ce nouveau code

Code:

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
Option Explicit
Sub Macro1()
Dim plgA As Range, plgB As Range, c As Range, Cel As Range
Dim Idem As Boolean
Dim i As Byte
Dim LigneAjout As Long
Dim firstaddress As String, a As String, b As String
    Application.ScreenUpdating = False
    Set plgA = Sheets("Administration").Range("A2:A" & Sheets("Administration").Range("A65536").End(xlUp).Row)
    Set plgB = Sheets("web").Range("A2:A" & Sheets("web").Range("A65536").End(xlUp).Row)
    Sheets("résultat").Range("A1").CurrentRegion.Offset(1, 0).ClearContents
    For Each Cel In plgA
        Idem = False
        Set c = plgB.Find(Cel.Value, LookIn:=xlValues, lookat:=xlWhole)
        If Not c Is Nothing Then
        c.EntireRow.Interior.ColorIndex = 6
        Cel.EntireRow.Interior.ColorIndex = 6
        Idem = True
        firstaddress = c.Address
        Do
            a = ""
            b = ""
            For i = 1 To 4
                a = a & UCase(c.Offset(0, i))
                b = b & UCase(Cel.Offset(0, i))
            Next i
            If a Like b Then
                Idem = True
                c.EntireRow.Interior.ColorIndex = 3
                Cel.EntireRow.Interior.ColorIndex = 3
                Exit Do
            Else
                Idem = False
            End If
            Set c = plgB.FindNext(c)
        Loop While Not c Is Nothing And c.Address <> firstaddress
        End If
        'Je copie si je n'ai pas trouvé de correspondance (Idem = False)
        If Not Idem Then
            LigneAjout = Sheets("résultat").Range("A65536").End(xlUp).Row + 1
            Cel.Resize(, 6).Copy Destination:=Sheets("résultat").Range("A" & LigneAjout)
        End If
        Set c = Nothing
    Next Cel
    Set plgA = Nothing
    Set plgB = Nothing
    Application.ScreenUpdating = True
End Sub

Attention : si le programme détecte une différence dans la comparaison de 2 chaines de caractères, il considère que les données sont différentes. C’est vrai par exemple s’il y a un espace supplémentaire entre 2 mots ou à la fin d’un mot.
Pour te faciliter la recherche, le programme surligne en jaune quand un nom équivalent est trouvé et en rouge quand la totalité des données est identique.

Cordialement.

09/04/2012, 19h01
Raphaelphp

Macro (suite)

Bonjour,

Merci pour cette reponse

Mais pourrais tu m'indiquer comment faire pour que la comparaison se fasse que sur le nom et le prenom (1 et 2eme colonne) ? SVP

cela reglerais mon probleme

SVP Merci

(Ta macro precedente est tres bien )
Raphael
09/04/2012, 19h19
Philippe Tulliez

Bonsoir,
Sans avoir à nouveau regardé le code donc pas testé.
Auparavant, tu faisais une boucle de 1 à 4 pour concaténer 4 colonnes, il faut donc faire une boucle de 1 à 2
Une autre manière de faire une concaténation
nLigne = 2 donc La Variable Ref sera le résultat de la concaténation des cellules A2 et D2

Code:

Ref = Cells(nLigne, 1) & Cells(nLigne, 4)

Tu peux aussi enlever les espaces avant et après en utilisant la fonction Trim et moi en général, j'ajoute la fonction Ucase

Code:

Ref = Ucase(Trim(Cells(nLigne, 1)) & Trim(Cells(nLigne, 4)))

Il faut tout de même faire attention aux homonymes.

Voici le code prenant en compte la comparaison sur le nom et le prénom, la suppression des espaces et la mise en majuscules.

Code:

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
Option Explicit
Sub Macro1()
Dim plgA As Range, plgB As Range, c As Range, Cel As Range
Dim Idem As Boolean
Dim i As Byte
Dim LigneAjout As Long
Dim firstaddress As String, a As String, b As String
    Application.ScreenUpdating = False
    Set plgA = Sheets("Administration").Range("A2:A" & Sheets("Administration").Range("A65536").End(xlUp).Row)
    Set plgB = Sheets("web").Range("A2:A" & Sheets("web").Range("A65536").End(xlUp).Row)
    Sheets("résultat").Range("A1").CurrentRegion.Offset(1, 0).ClearContents
    For Each Cel In plgA
        Idem = False
        Set c = plgB.Find(Cel.Value, LookIn:=xlValues, lookat:=xlWhole)
        If Not c Is Nothing Then
        c.EntireRow.Interior.ColorIndex = 6
        Cel.EntireRow.Interior.ColorIndex = 6
        Idem = True
        firstaddress = c.Address
        Do
            If UCase(Trim(c.Offset(0, 1))) Like UCase(Trim(Cel.Offset(0, 1))) Then
                Idem = True
                c.EntireRow.Interior.ColorIndex = 3
                Cel.EntireRow.Interior.ColorIndex = 3
                Exit Do
            Else
                Idem = False
            End If
            Set c = plgB.FindNext(c)
        Loop While Not c Is Nothing And c.Address <> firstaddress
        End If
        'Je copie si je n'ai pas trouvé de correspondance (Idem = False)
        If Not Idem Then
            LigneAjout = Sheets("résultat").Range("A65536").End(xlUp).Row + 1
            Cel.Resize(, 6).Copy Destination:=Sheets("résultat").Range("A" & LigneAjout)
        End If
        Set c = Nothing
    Next Cel
    Set plgA = Nothing
    Set plgB = Nothing
    Application.ScreenUpdating = True
End Sub

Il te reste à voir les doublons dans la feuille Administration.
J’ai noté en particulier :
CHATENAY Karine
GAUTIER Florence

Cordialement.