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

[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+