Discussion :

[Aimey]

Bonjour,
Dans la feuille 1 j'entre des noms de fournisseurs et dans la feuille 2 j'aimerais que ma liste de fournisseurs s'insère automatiquement. Il doit vérifier si le nom que j'entre existe déjà, s'il n'existe pas il doit s'inscrire dans la feuille 2.

Merci infiniment pour votre aide et bonne année à tous!
Aimey

[Klin89]

Bonsoir le forum et bonne année à tous

Une évenementielle à placer dans le module de la Feuille 1:

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
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim a, e
    If Intersect(Target, Columns("a")) Is Nothing Then Exit Sub
    a = Range("a1").CurrentRegion
    If Not IsArray(a) Then
        Sheets(2).Columns("a").ClearContents
        Sheets(2).Range("a1").Value = a
        Exit Sub
    End If
    With CreateObject("Scripting.Dictionary")
        For Each e In a
            If Not IsEmpty(e) And Not .exists(e) Then .Add e, Nothing
        Next
        Sheets(2).Columns("a").ClearContents
        Sheets(2).Range("a1").Resize(.Count).Value = Application.Transpose(.keys)
    End With
End Sub

klin89

[sogedic]

Une variante (très inspirée) qui ajoute les nouveaux fournisseurs saisis dans la feuil1 sans supprimer ceux déjà existants en feuil2

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
'Cocher la référence Microsoft Scripting runtime
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim a, e
    Dim dicoFrs As Scripting.Dictionary
    Set dicoFrs = New Scripting.Dictionary
    If Intersect(Target, Columns("a")) Is Nothing Then Exit Sub
    a = Range("a1").CurrentRegion
    If Not IsArray(a) Then
        Sheets(2).Columns("a").ClearContents
        Sheets(2).Range("a1").Value = a
        Exit Sub
    End If
 
    For Each e In a
        If Not IsEmpty(e) And Not dicoFrs.exists(e) Then dicoFrs.Add e, Nothing
    Next
    With Sheets(Feuil2.Name)
        a = .Range("a1").CurrentRegion
        For Each e In a
            If Not IsEmpty(e) And Not dicoFrs.exists(e) Then dicoFrs.Add e, Nothing
        Next e
    End With
    Sheets(2).Columns("a").ClearContents
    Sheets(2).Range("a1").Resize(dicoFrs.Count).Value = Application.Transpose(dicoFrs.keys)
 
End Sub

Mais c'est le même principe

[araigné]

Bonjour,

je vous propose une autre variante plus optimisée (pas de boucle sur un objet Excel -> ce qui rend inutile l'utilisation du dico en terme de performance ) de plus il n'y a pas besoin de références supplémentaire et donc compatible sur mac.

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
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
Option Explicit
 
Private Const DestinationSheetName = "Feuil2"
Private Const ColumnToCare = 1
 
Private lShtDest As Worksheet
Private lIsSet As Boolean
Private lItems() As String, lNbItems As Long
 
Private Sub Worksheet_Change(ByVal Target As Range)
 
    If Target.Column <> ColumnToCare Then Exit Sub
 
    If Not lIsSet Then Call Init
 
    If IsNull(Target.Text) Then
        Dim VarTargets() As Variant
        VarTargets = Target.Value2
        Dim i As Long
        For i = 1 To UBound(VarTargets)
            Call CheckItem(CStr(VarTargets(i, 1)))
        Next
    Else
        Call CheckItem(CStr(Target.Text))
    End If
 
End Sub
 
Private Sub CheckItem(StrTarget As String)
 
    Dim i As Long
 
    For i = 0 To lNbItems
        If lItems(i) = StrTarget Then Exit For
    Next
 
    If i > lNbItems Then
        lNbItems = lNbItems + 1
        ReDim Preserve lItems(lNbItems)
        lItems(lNbItems) = StrTarget
        lShtDest.Cells(lNbItems + 2, 1) = StrTarget
    End If
 
End Sub
 
Private Sub Init()
 
    lIsSet = True
 
    Set lShtDest = ThisWorkbook.Sheets(DestinationSheetName)
 
    Dim NbLignes As Long
    NbLignes = lShtDest.Cells(lShtDest.Rows.Count, 1).End(xlUp).Row
 
    'La première ligne est réservée pour le nom de la colonne (ex : Fournisseurs)
    lNbItems = NbLignes - 3
 
    If lNbItems = -2 Then
        lShtDest.Cells(1, 1) = "Fournisseurs"
        lNbItems = -1
    End If
 
    If lNbItems <> -1 Then ReDim lItems(lNbItems)
 
    Dim VarTab() As Variant
    ReDim VarTab(1 To NbLignes, 0)
    If NbLignes <> 1 Then VarTab = lShtDest.Range(lShtDest.Cells(1, 1), lShtDest.Cells(NbLignes, 1))
 
    Dim i As Long
    For i = 0 To lNbItems
        lItems(i) = VarTab(i + 2, 1)
    Next
 
    Erase VarTab
 
End Sub

Evidemment cela est "optimisable" si l'on désire que cela fonctionne pour plusieurs feuilles en même temps.
Pour 1 000 000 fournisseurs, il faut 0.9 s d'initialisation, puis 0.04 s pour trouver/ajouter un élément.
Fonctionne également pour une plage copier/collée. -> Edit

@+