Discussion :

[formabox]

Hello l'équipe,

J'ai consulter vos tutoriaux pour créer une liste déroulante qui va rechercher les données de la colonne A d'une feuille nommée RH et de prendre les valeurs de façon unique.

Voici mon code :

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
Private Sub UserForm_Initialize()
 
Dim i As Integer
 
For i = 1 To Sheets("RH").Range("A65536").End(xlUp).Row
 
    CboNom = Sheets("RH").Range("A" & i)
 
    If CboNom.ListIndex = -1 Then CboNom.AddItem Sheets("RH").Range("A" & i)
 
Next i
 
End Sub

Si j'enlève la ligne du IF, je n'ai pas de message d'erreur mais il inscrit dans la liste que le dernier élément de ma colonne A... Normal...

Mais si je laisse le IF, j'ai le message d'erreur suivant : Erreur d'exécution '380' Impossible de définir la propriété Value. Valeur de propriété non valide.

La fenêtre de déboguage m'emmène pas sur le code du userform mais sur le code de la feuille où j'ai le bouton qui lance le userform...

J'ai esssayé de remplacé la valeur -1 par 0 ou 1 et la macro passe... bien sûr que la liste ne s'affiche pas correctement mais il n'y a pas de bug... alors que dès que je note -1, il m'emmène sur l'erreur 380...

Est-ce que quelqu'un peut m'orienter ? Car là je sèche...

Merci et belle soirée,

[casefayere]

Bonsoir,
Un exemple avec lequel tu pourras te reservir des deux derniers modules pour d'autres controles à remplir :

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
Option Explicit
 
Dim Doubl As Object, derlg As Long, tb(), listA()
Private Sub UserForm_Initialize()
Test_doublons
CboNom.List = WorksheetFunction.Transpose(listA)
End Sub
Sub Test_doublons()
Set Doubl = CreateObject("Scripting.Dictionary")
Erase tb
With Sheets("RH")
   derlg = .Range("A" & .Rows.Count).End(xlUp).Row
   IdentifieDoublons .Range("A3:A" & derlg)
End With
End Sub
 
Sub IdentifieDoublons(Plg As Range)
Dim x As Long, y As Long
y = 0
ReDim tb(1 To derlg)
tb = Plg.Value
On Error Resume Next
For x = 1 To UBound(tb)
  Doubl.Add tb(x, 1), CStr(tb(x, 1))
  If Err = 0 Then
    y = y + 1
    ReDim Preserve listA(1 To y)
    listA(y) = tb(x, 1)
  End If
  Err.Clear
Next x
End Sub

Bonne soirée

[formabox]

Hello Casafayere,

Un grand merci pour ton code qui fonctionne à merveille

Me reste maintenant à lire attentivement toutes tes lignes afin d'essayer de comprendre ce qui se passe...

Peux-tu m'expliquer "en gros" l'avantage de ta solution ?

Entretemps, j'ai compris mon erreur dans mon code... J'avais oublié de placer la ligne Options Explicit en haut de mon code...

Merci à vous et toute belle soirée,

[casefayere]

Re,
Une petite correction à apporter, copies les codes ci-dessous dans un module, de préférence et enlèves les du code del'USF :

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
Option Explicit
 
Public Doubl As Object, derlg As Long, tb(), listA()
Sub Test_doublons()
Set Doubl = CreateObject("Scripting.Dictionary")
Erase tb
With Sheets("RH")
   derlg = .Range("A" & .Rows.Count).End(xlUp).Row
   IdentifieDoublons .Range("A3:A" & derlg)
End With
End Sub
 
Sub IdentifieDoublons(Plg As Range)
Dim x As Long, y As Long
y = 0
ReDim tb(1 To derlg)
tb = Plg.Value
On Error Resume Next
For x = 1 To UBound(tb)
  Doubl.Add tb(x, 1), CStr(tb(x, 1))
  If Err = 0 Then
    y = y + 1
    ReDim Preserve listA(1 To y)
    listA(y) = tb(x, 1)
  End If
  Err.Clear
Next x
End Sub

l'avantage est que
1 - tu pourras te servir de ces codes si tu as d'autres combos ou listbox à remplir sans doublons, ou ils te serviront d'exemple pour un autre projet
2 - Le calcul est rapide car je passe par des tableaux

n'hésites pas si tu ne comprends pas
bonne soirée

[casefayere]

Ci-dessous, les codes avec leur explication :
dans l'USF

Code :

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

1
2
3
4
Private Sub UserForm_Initialize()
Test_doublons 'on va directement sur ce Code
CboNom.List = WorksheetFunction.Transpose(listA) 'on remplit ta combo avec le résultat obtenu
End Sub

Dans un module :

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
Option Explicit
 
Public Doubl As Object, derlg As Long, tb(), listA() 'variables qui servent pour tout le projet
Sub Test_doublons()
Set Doubl = CreateObject("Scripting.Dictionary") 'variable objet qui n'accepte que les valeurs uniques
Erase tb ' on réinitialise cette variable tableau globale, par sécurité
With Sheets("RH")
   derlg = .Range("A" & .Rows.Count).End(xlUp).Row 'ta dernière ligne de ta colonne (A, en l'occurence)
   IdentifieDoublons .Range("A3:A" & derlg) 'on va sur ce code en identifiant la variable "Plg"
End With
End Sub
 
Sub IdentifieDoublons(Plg As Range)
Dim x As Long, y As Long
y = 0
ReDim tb(1 To derlg) 'on redimensionne la variable tableau 'tb",à partir de 1 jusque ta dernière ligne
tb = Plg.Value 'on donne les valeurs de ta colonne à la variable
On Error Resume Next 'évites les messages d'erreur pour ce qui suit
For x = 1 To UBound(tb) 'ubound est la dimension du tableau
  Doubl.Add tb(x, 1), CStr(tb(x, 1)) 'on donne à l'objet une clé et un item
  If Err = 0 Then 'si il n'y a pas d'erreur
    y = y + 1 ' on incrémente y de 1
    ReDim Preserve listA(1 To y) 'on redimensionne le tableau + 1
    listA(y) = tb(x, 1) 'onajoute une valeur si la valeur est unique
  End If
  Err.Clear 'on réinitialise les valeurs d'erreur
Next x
End Sub

PS : et surtout si tu es OK,n'oublies pas de cliquer sur

[formabox]

Merci pour les précisions et de la rapidité dans les réponses...

[casefayere]

Je voudrais m'excuser auprès de Bbil qui a supprimé son message, et je reprends sa réflexion

à quoi sert cette ligne ?

Code :

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

CboNom = Sheets("RH").Range("A" & i)

Je détaille donc tes erreurs :

Code :

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

1
2
3
4
5
6
7
8
9
Private Sub UserForm_Initialize()
Dim i As Integer
For i = 1 To Sheets("RH").Range("A65536").End(xlUp).Row ' avec excel 2007 tu as 1048576 ligne
  CboNom = Sheets("RH").Range("A" & i) 'ici, tu ne poses pas de condition et de plus l'écriture est fausse
  'il faudrait
  'CboNom.Additem Sheets("RH").Range("A" & i)
  If CboNom.ListIndex = -1 Then CboNom.AddItem Sheets("RH").Range("A" & i) 'là ça ne veux rien dire
Next i
End Sub

en reprenant ton exemple, sans autre module, tu aurais pu faire comme ça :

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
Option Explicit
Dim Doubl As Object, derlg As Long, tb, listA(), x As Long
 
Private Sub UserForm_Initialize()
Set Doubl = CreateObject("Scripting.Dictionary") 'variable objet qui n'accepte que les valeurs uniques
With Sheets("RH")
  derlg = .Range("A" & .Rows.Count).End(xlUp).Row 'ta dernière ligne de ta colonne (A, en l'occurence)
  ReDim tb(1 To derlg) 'on redimensionne la variable tableau 'tb",à partir de 1 (Option base 1) jusque ta dernière ligne
  tb = .Range("A2:A" & derlg) 'on donne les valeurs de ta colonne à la variable
  On Error Resume Next 'évite les messages d'erreur pour ce qui suit
  For x = 1 To UBound(tb) 'ubound est la dimension du tableau
    Doubl.Add tb(x, 1), CStr(tb(x, 1)) 'on donne à l'objet une clé et un item
    If Err = 0 Then 'si il n'y a pas d'erreur
      CboNom.AddItem tb(x, 1) 'on ajoute une valeur si la valeur est unique
    End If
    Err.Clear 'on réinitialise les valeurs d'erreur
  Next x
End With
End Sub

a +