Discussion :

[P96O1004]

Bonjour à tous,

J'ai un problème parait très simple pour vous mais je n'arrive pas à le résoudre.
J'ai une liste de produit, je veux créer une autre liste de 5 premier caractères sans d'occurrence.

Mon code marche bien :

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
 
Sub List_prodref()
i = 7
j = 7
Dim shortrefpro As String
Dim refpro As String
 
While Not IsEmpty(Sheets(1).Range("A" & i).Value)
 
                refpro = Sheets(1).Range("A" & i).Value
                shortrefpro = Left(refpro, 5)
                Sheets(1).Range("F" & j).Value = shortrefpro
                i = i + 1
                        If InStr(shortrefpro, Left(Range("A" & i).Value, 5)) = 0 Then
                            j = j + 1
                        End If
Wend
End Sub

Mais quand je veux faire la même chose pour plusieurs feuilles dans ce classeur, le code ci-dessous ne marche que pour la première feuille :

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
Sub List_prodref()
i = 7
j = 7
 
Dim shortrefpro As String
Dim refpro As String
 
For k = 1 To Sheets.Count
Sheets(k).Select
 
            While Not IsEmpty(Sheets(k).Range("A" & i).Value)
 
                            refpro = Sheets(k).Range("A" & i).Value
                            shortrefpro = Left(refpro, 5)
                            Sheets(k).Range("F" & j).Value = shortrefpro
                                    i = i + 1
                                    If InStr(shortrefpro, Left(Sheets(k).Range("A" & i).Value, 5)) = 0 Then
                                        j = j + 1
                                    End If
 
            Wend
Next k
End Sub

Et si les produits ne sont pas bien classés, mon code marche pas du tout.
Le fait d'éviter l'occurrence me donne beaucoup de soucis.

Merci pour votre aide.

[Gorfael]

Salut P96O1004 et le forum
On peut amélioré la macro (supprimer select) mais en changeant simplement :

Code :

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

1
2
3
4
5
6
7
8
9
Sub List_prodref()
i = 7
j = 7
 
Dim shortrefpro As String
Dim refpro As String
 
For k = 1 To Sheets.Count
Sheets(k).Select

Par

Code :

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

1
2
3
4
5
6
7
8
Sub List_prodref()
Dim shortrefpro As String
Dim refpro As String
 
For k = 1 To Sheets.Count
Sheets(k).Select
i = 7
j = 7

ça marchera sans doute mieux
A+

[P96O1004]

merci énormément, j'ai compris pourquoi ça marche pas. C'est si simple.

Je vais bosser ce soir pour éviter l'occurrence si la liste n'est pas bien rangée.

[le petit nicolas]

salut,
ton code ne marche pas quand les cellules ne sont pas triées, c'est normal puisque tu compare à la cellule suivante seulement (i+1)

regardes du coté des techniques permettant de créer des listes sans doublons :
tuto de silkyroad : http://silkyroad.developpez.com/excel/doublons/#LIV-A
et une utilisation de ce système : http://www.developpez.net/forums/d70...colonne-ligne/

l'idée c'est de construire ta liste en mémoire dans une collection, chaque élément de la collection a un "tag" qui doit être unique sinon l'élément est refusé (dans ton cas le tag sera Left(ValeurCellule, 5)).

Puis quand tu as fini tu fais une boucle pour écrire les élements de ta collection où tu veux (dans ton cas la colonne F)

à plus

[laetitia]

bonjour P96O1004 Gorfael le petit nicolas le forum
on peut aussi passer par un tableau inter.... tres rapide
& Scripting.Dictionary pour les doublons

Option Explicit

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
Sub tri()
Dim t As Variant, t2() As String, M As Object, X As Long, i As Long, k As Long, Ws As Worksheet
On Error Resume Next
Application.ScreenUpdating = False
For Each Ws In Worksheets
Worksheets(Ws.Name).Activate
Set M = CreateObject("Scripting.Dictionary")
t = Range("a7:a" & Range("a65536").End(xlUp).Row)
 X = 1
For i = 1 To UBound(t)
t(i, 1) = Left(t(i, 1), 5)
If Not M.Exists(t(i, 1)) And t(i, 1) <> "" Then
M.Add t(i, 1), t(i, 1)
ReDim Preserve t2(1 To 1, 1 To X)
For k = 1 To 1
t2(k, X) = (t(i, k)): Next k: X = X + 1: End If: Next i
Range("f7").Resize(UBound(t2, 2), UBound(t2, 1)) = Application.Transpose(t2)
Erase t, t2: Next Ws: Sheets(1).Select
End Sub

[Gorfael]

Salut à toutes et tous
une autre proposition

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
Sub List_prodref()
Dim Coll As New Collection
Dim F As Worksheet
Dim X As Long
For Each F In Sheets
'Pour chaque feuille dans la collection des feuilles
    Range(F.[F7], F.Range("F" & F.Rows.Count).End(xlUp)).ClearContents
    'on efface l'ancienne liste
    On Error Resume Next
    'en cas d'erreur, on continue
    For X = 7 To F.Range("A" & F.Rows.Count).End(xlUp).Row
    'pour x=7 à la dernière ligne non vide en A
        Coll.Add Left(F.Range("A" & X), 5), Left(F.Range("A" & X), 5)
        'on ajoute un objet à la collection (clé = 5 premières lettre)
    Next X
    'X suivant
    On Error GoTo 0
    'on remet en route le traitement des erreurs par excel
    For X = 1 To Coll.Count
    'Pour x=1 à nombre d'objets dans la collection
        F.Range("F" & X + 6) = Coll(X)
        'on inscrit l'objet X en F(X+6)
    Next X
    'X suivant
Next F
End Sub

On utilise l'erreur (457) que génère un doublon dans la clé d'une collection pour les éliminer.

Nota J'efface l'ancienne liste, ne connaissant pas le but, je parts du principe que la liste peut diminuer. Je parts aussi du principe qu'il y a au moins une valeur dans les colonnes A et F à partir de la ligne 7. Dans le cas contraire, il faudrait faire un test pour ne pas effacer laligne 6

laetitia : peux-tu me dire comment trouver de l'aide pour comprendre ta méthode (Set M = CreateObject("Scripting.Dictionary")) ?
A+