Discussion :

[mokha]

Salut à tous,

J'ai un tableau Excel et je voudrais programmer avec VBA de manière à trouver tous les code articles qui ont la même date et le même N° de lot.

Merci de votre aide

[ouskel'n'or]

Un filtre avec deux critères ne suffirait-il pas ?

[mokha]

J'ai plus de 2000 articles et ça prend trop de temps de regarder un par un

[ouskel'n'or]

Tu dois au préalable établir la liste de tes articles sans doublon puis pour chaque article, chercher la correspondance Article, date et N° de lot.
(trois critères au lieu de deux contrairement à ce que j'ai mis précédemment)
Mais tu ne dis pas sous quelle forme tu veux récupérer tes articles... (dans une nouvelle feuille ?) ni ce que tu veux en faire...
A+

[mokha]

Je viens de faire un tour sur le forum.

Plus faire plus simple, je veus effacer tous mes doublons.

Admettons, j'ai ce tableau :

Code article Date N°lot
1 01/01 5
2 12/05 9
1 01/01 5
4 15/09 10

J'ai la 1ère et le 3ème ligne identique et je voudrais effacer la troisième.

Merci de votre aide

[ouskel'n'or]

Tu peux jeter un oeil dans la FAQ VBA-Excel au chapitre "Comment supprimer les doublons contenus dans une plage de cellules ?Le problème est que tu as trois critères, tu devras donc, pour chaque article trouvé, vérifier la correspondance des date et N° de lot.
Pour ça, tu devras ajouter un test sur les deux colonnes concernées dans cette boucle que je t'explique :
Cette boucle "tente" d'ajouter un élément à la collection, par exemple, ton article. Si cet élément existe déjà, celà provoque une erreur et on passe à la ligne suivante.
Pour toi, l'élément à ajouter n'est donc pas seulement l'article mais les trois critères qui t'intéressent, Article & date & N° de lot.
Pour ajouter un élément à la collection, tu dois donc concaténer les trois critères.
Je suppose que tes articles sont en colonne A, les dates en colonne B et le N° de lot en colonne C. Ce qui donnerait

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
    On Error Resume Next
    'Boucle sur les cellules de la plage cible
    For Each Cell In Plage
        'Création d'une collection de données uniques (sans doublons)
        'Un.Add Cell, CStr(Cell) 'remplacé par la ligne suivante
'Modif
        Un.add Cell, Cell & cdbl(Cell.offset(0,1).value) & Cstr(cell.offset(0,2).value)
        'Une erreur survient si l'élément existe dans la collection.
        'La procédure enregistre le numéro de ligne correspondant dans un tableau.
        If Err.Number <> 0 Then
            x = x + 1
            ReDim Preserve Tableau(1 To x)
            Tableau(x) = Cell.Row
            Err.Clear
        End If
    Next Cell
    On Error GoTo 0

Comme je n'ai pas testé, si la ligne

Un.add Cell, Cell & cdbl(Cell.offset(0,1).value) & Cstr(cell.offset(0,2).value)

provoque une erreur, passe par une variable

Code :

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

1
2
3
Dim Temp as variant
Temp = Cell & cdbl(Cell.offset(0,1).value) & Cstr(cell.offset(0,2).value)
Un.add Cell, Temp

Tu dis
A+

Edit
Le reste du code se trouve dans la FAQ à l'adresse que j'ai indiquée

[derech]

BOnjour Mokha,

tu peux essayer ce code. Au préalable fais un tri de ton tableau de façon à avoir les données identiques à la suite les unes des autres.

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
 
Sub Supdoublons
Dim i As Integer
Dim derli As Integer
 
 'Recherche de la dernière ligne de la colonne A
  derli = Columns(1).Find("*", , , , , xlPrevious).Row
  ' boucle qui commence à la fin à cause des suppression de cellules
  For i = derli To 2 Step -1
    If Cells(i, 1) = Cells(i - 1, 1) And cells(i,2) = cells(i-1,2) And cells(i,3)=cells(i-1,3) Then
      Cells(i,1).ClearContents
      Cells(i,2).ClearContents
      Cells(i,3).ClearContents
    End If
  Next
end sub

Ensuite tu refais un tri de ton tableau et normalement c'est bon

[ouskel'n'or]

Ok pour ton code, derech Mais au lieu de ClearContents, je mettrais

Code :

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

cells(i, 1).EntireRow.delete

Juste une remarque : Le tri déplace les données, ce qui peut ne présenter aucun inconvénient mais mieux vaut le savoir

[derech]

Oui je suis d'accord mais l'execution sera beaucoup plus rapide si il efface le contenu des cellules au lieu de supprimer les lignes.Ensuite il refait un tri afin de combler les vides entre les cellules.

[ouskel'n'or]

Une autre remarque : en n'effaçant que les cellules concernées, tu n'effaces pas la ligne... => problème possible lors du tri puis de la suppression des lignes incomplètes. Deux tris sont en outre nécessaires.
Je viens de retrouver ça où toutes les options sont possibles : Supprimer ou simplement masquer les doublons, doublons se trouvant ou non dans des cellules contiguës.
Il m'étonnerait bien que ce soit plus lent. Tu devrais tester

[derech]

Oui c'est vrai si il y a davantages de colonnes que les 3 dans lequelles on cherche les doublons.
Au niveau de la rapidité j'ai fai l'expérience avec 2000 lignes et c'était particulièrement lent ..mais je pense que je peux reporter la faute sur mon processeur qui lui est particulièrement vieux!

Merci du conseil en tout cas.

[Qwazerty]

SAlut

Niveau performance je sais pas trop ce que donne mon code .... y'a quand même beaucoup test, faudrait avoir un fichier pour voir, je le met quand même

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
Dim CelFinded As Range, CelTest As Range
Dim StrFAddress As String
Dim PrevRow As Integer
Dim IdemCel As Boolean
 
PrevRow = 0
IdemCel = False
For Each CelTest In Range(Range("A2"), Cells(Rows.Count, "A").End(xlUp)) 'pas top la liste va se reduire
    If CelTest.Value <> "" Then
        With Range(CelTest.Offset(1, 0), Cells(Rows.Count, "A").End(xlUp))
            Set CelFinded = .Find(CelTest.Value, LookIn:=xlValues, lookat:=xlWhole, searchdirection:=xlPrevious)
            If Not CelFinded Is Nothing Then
                StrFAddress = CelFinded.Address
                Do
                    If CelTest.Offset(0, 1) = CelFinded.Offset(0, 1) Then
                        If CelTest.Offset(0, 2) = CelFinded.Offset(0, 2) Then 'je pense plus rapide de faire 2 boucles a toi de voir laquelle contient le plus de redondance "inutilisable"
                            PrevRow = CelFinded.Row
                            If CelFinded.Address = StrFAddress Then IdemCel = True
                        End If
                    End If
 
                    Set CelFinded = .FindPrevious(CelFinded)
                    If PrevRow <> 0 Then
                        Rows(PrevRow).Delete
                        StrFAddress = Range(StrFAddress).Offset(-1, 0).Address
                        PrevRow = 0
                        If IdemCel Then Exit Do 'pour ne pas planter a l'appel de CelFinded.address
                    End If
                Loop While Not CelFinded Is Nothing And CelFinded.Address <> StrFAddress
            End If
        End With
    End If
Next
 
End Sub

J'ai remarquer un truc par contre, dans l'aide la méthode pour le Find utilise ce test en sortie

Code :

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

1
2
 
Loop While Not CelFinded Is Nothing And CelFinded.Address <> StrFAddress

Mais je trouve ca un peu *** par ce que si CelFinded is nothing ... alors celfinded.address provoque une erreur ... quelqu'un voit l'intérêt de la chose, peu être que je suis en train de cracker

A++
Qwaz

[ouskel'n'or]

quelqu'un voit l'intérêt de la chose, peu être que je suis en train de cracker

Voui, tu craques ! Y'a pas d'erreur... si la boucle est correctement construite... par exemple, si à la place de

Set CelFinded = .FindPrevious(CelFinded)
If PrevRow <> 0 Then

tu mets

Code :

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

1
2
3
4
5
Set c = .FindPrevious(c)
If not c is nothing then
      adresse = c.address
      exit do
endif

Mais dans ce cas, on écrit tout le reste de manière différente

[Qwazerty]

SAlut
Nan c'est pas en rapport avec mon code, je vais mettre l'exemple vba, je voudrais pas trop pourris le post du collègue quand même... gomen nasai

Code :

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

1
2
3
4
5
6
7
8
9
10
With Worksheets(1).Range("a1:a500")     
Set c = .Find(2, lookin:=xlValues)     
If Not c Is Nothing Then    
     firstAddress = c.Address     
     Do     
         c.Value = 5    
         Set c = .FindNext(c)  
     Loop While Not c Is Nothing And c.Address <> firstAddress     
End If  
End With

en arrivant sur le loop on test si c n'est pas nothing ET si c.address <> .., hors excel fait les 2 tests il ne s'arrête pas au premier si celui ci est faut et donc dans l'hypothèse ou on arrive sur cette ligne avec un c qui est effectivement Nothing ... ben le c.address plante tout, non ?

Bon aller je vais me coucher, la nuit porte conseil
A++
Qwaz

[ouskel'n'or]

Non, s'il ne trouve pas tu n'entres pas dans la boucle, et si tu n'entres pas dans la boucle, tu sorts
S'il trouve le premier, puis le second puis de nouveau le premier, alors c.Address = firstAddress et là aussi tu sorts.
Allez, bonne nuit !

[Qwazerty]

SAlut
On est d'accord, donc a quoi sert

Code :

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

 Not c Is Nothing And

c'est completement inutil, c'est bien ce que je dis.
a++
Qwaz

[ouskel'n'or]

Hé non, tu n'as pas raison. Quand la boucle ne trouve plus la donnée vers la fin de la feuille, la recherche reprend au début et ça devient une boucle sans fin, sans fin, sans fin, sans fin

[mokha]

Bonjour,

Avec le programme suivant, j'arrive à supprimer les doublons du tableau 1 mais pas du tableau 2 (les 2 tableaux sont dans le fichier ci-joint).

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
Sub SupprimeDoublons()
    Dim Plage As Range, Cell As Range
    Dim Un As New Collection
    Dim Tableau() As Integer
    Dim x As Integer
    Dim Temp As Variant
 
 
    'Définit la plage de cellules pour la recherche de doublons
    Set Plage = Worksheets("Feuil1").Range("A1:A20")
 
   On Error Resume Next
    'Boucle sur les cellules de la plage cible
    For Each Cell In Plage
        'Création d'une collection de données uniques (sans doublons)
        'Un.Add Cell, CStr(Cell) 'remplacé par la ligne suivante
'Modif
 
        Temp = Cell & CDbl(Cell.Offset(0, 1).Value) & CStr(Cell.Offset(0, 2).Value)
        Un.Add Cell, Temp
 
        'Une erreur survient si l'élément existe dans la collection.
        'La procédure enregistre le numéro de ligne correspondant dans un tableau.
        If Err.Number <> 0 Then
            x = x + 1
            ReDim Preserve Tableau(1 To x)
            Tableau(x) = Cell.Row
            Err.Clear
        End If
    Next Cell
    On Error GoTo 0
 
    'On sort si aucun doublon n'a été trouvé.
    If x = 0 Then Exit Sub
 
    'Fige l'écran pendant la suppression des lignes
    Application.ScreenUpdating = False
 
    'Boucle sur le tableau pour supprimer les lignes contenant des doublons.
    For x = UBound(Tableau) To LBound(Tableau) Step -1
        Worksheets("Feuil1").Rows(Tableau(x)).EntireRow.Delete
    Next x
 
    Application.ScreenUpdating = True
End Sub

Je ne vois pas où est l'erreur...

Merci de votre aide

[ouskel'n'or]

Continue sur la même discussion si le problème d'origine n'a pas été résolu.
J'ai donc fusionné les deux discussions afin qu'on s'y retrouve.

Ton problème :
Avant d'ouvrir ton fichier... As-tu un message d'erreur ? Sur quelle ligne ?
Si pas de message, que se passe-t-il ?
A+

[mokha]

Ok

J'ai pas de message d'erreur, par contre, après exécution, tout le tableau disparaît.