comment rendre une combobox plus rapide

snoopy07

XLDnaute Occasionnel
Bonjour

J utile une combobox dans un formulaire quand je remplie le textbox Cp et que je clic sur ma combobox celle ci met tu temps a s ouvrir

ex Quand le code postale et au début de ma liste ex 01000 la combobox s ouvre en moins d'une seconde mais quand mon code postal est éloigne du début de ma liste ex 72000 la combobox met un temps fou a s ouvrir

quel code dois je utiliser pour la rendre plus rapide voici comment j'ai programme mon formulaire


Private Sub txtCp_Exit(ByVal Cancel As MSForms.ReturnBoolean)
Dim Lg&, i%, Sh As Worksheet, Ctl As Range
Set Sh = Sheets("Code Postaux")
On Error GoTo Erreur
For Each Ctl In Sh.Range("A2:A" & Sh.Range("A" & Rows.Count).End(xlUp).Row)
If Me.txtCp = Ctl.Text Then
Lg = Ctl.Row
Exit For
End If
Next Ctl
i = 3
Me.txtVille.Clear
Do
Me.txtVille.AddItem Sh.Cells(Lg, i)
i = i + 1
Loop Until Sh.Cells(Lg, i) = ""
triList
Me.txtVille.SetFocus
Me.txtVille.DropDown
Me.txtDépartement.Text = Sh.Cells(Lg, 50)
Me.txtRégion.Text = Sh.Cells(Lg, 51)
Me.txtPays.Text = Sh.Cells(Lg, 52)
Exit Sub
Erreur:
MsgBox "Ce code postal n'est pas répertorié", vbInformation + vbOKOnly, "Donnée Manquante"
Me.txtCp.SetFocus
Me.txtCp.Text = ""
End Sub



Private Sub UserForm_initialize()
'***** plus rapide***********
Civilite.List() = Array("", "Mr", "Mme", "Melle", "Dr", "Maitre")
End Sub
Private Sub cmdAjouter_Click()
Dim numLigneVide& 'quand il s'agit des lignes il faut mettre en long
'on active la feuille "Carnet"
Worksheets("Carnet").Activate
'on trouve la derniere ligne vide du tableau et on enregistre le numéro de ligne dans la variable numLigneVide
numLigneVide = ActiveSheet.Columns(2).Find("").Row
'on verifie que les champs obligatoire sont correctement remplis

'***** si données obligatoires il faut sortir de la macro pour pouvoir vérifié de nouveau****
On Error GoTo Erreur
If txtNom.Text = "" Then Err.Raise Number:=vbObjectError + 1, Source:="TxtNom", Description:="Veuillez remplir le nom de votre contact"
If txtPrénom.Text = "" Then Err.Raise Number:=vbObjectError + 1, Source:="txtPrénom", Description:="Veuillez remplir le prénom de votre contact"
On Error GoTo 0
'**********************
'on remplit les données dans notre tableau
AfficheTableau numLigneVide
'on efface le formulaire et on replace le curseur sur le premier champs (Civilite)
RAZ
'on fait le tri par ordre alphabétique automatiquement sur la colonne Nom
Trier numLigneVide
Exit Sub
Erreur:
MsgBox Err.Description, vbCritical + vbOKOnly, "Champs manquant"
Me.Controls(Err.Source).SetFocus
End Sub

Private Sub cmdFermer_Click()
'frmNouveau.Hide le cache
Unload Me ' le ferme
End Sub

Private Sub AfficheTableau(Lg&)
With ActiveSheet
.Cells(Lg, 1) = Civilite.Text
.Cells(Lg, 2) = StrConv(txtNom.Text, vbUpperCase)
.Cells(Lg, 3) = StrConv(txtPrénom.Text, vbProperCase)
.Cells(Lg, 4) = StrConv(txtSurnom.Text, vbProperCase)
.Cells(Lg, 5) = txtPortable.Text
.Cells(Lg, 6) = txtFixe.Text
.Cells(Lg, 7) = txtBoulot.Text
.Cells(Lg, 8) = txtEmail1.Text
.Cells(Lg, 9) = txtEmail2.Text
.Cells(Lg, 10) = StrConv(txtAdresse.Text, vbProperCase)
.Cells(Lg, 11) = txtCp.Text
.Cells(Lg, 12) = StrConv(txtVille.Text, vbProperCase)
.Cells(Lg, 13) = StrConv(txtDépartement.Text, vbProperCase)
.Cells(Lg, 14) = StrConv(txtRégion.Text, vbProperCase)
.Cells(Lg, 15) = StrConv(txtPays.Text, vbProperCase)
End With
End Sub

Private Sub RAZ()
Civilite.Text = ""
txtNom.Text = ""
txtPrénom.Text = ""
txtSurnom.Text = ""
txtPortable.Text = ""
txtFixe.Text = ""
txtBoulot.Text = ""
txtEmail1.Text = ""
txtEmail2.Text = ""
txtAdresse.Text = ""
txtCp.Text = ""
txtVille.Text = ""
txtDépartement.Text = ""
txtRégion.Text = ""
txtPays.Text = ""
Civilite.SetFocus
End Sub
Private Sub Trier(Lg&)
With ActiveWorkbook.Worksheets("Carnet").Sort
.SortFields.Clear
.SortFields.Add Key:=Range("B2:B" & Lg), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SortFields.Add Key:=Range("C2:C" & Lg), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange Range("A3:O" & Lg)
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub

Private Sub triList()
'Tri le contenu du ComboBox par ordre alphabétique
With Me.txtVille
For i = 0 To .ListCount - 1
For j = 0 To .ListCount - 1
If .List(i) < .List(j) Then
strTemp = .List(i)
.List(i) = .List(j)
.List(j) = strTemp
End If
Next j
Next i
End With
End Sub


je vous mon fichier:

Document Cjoint



merci d'avance

cordialement

Snoopy 07
 
Dernière édition:

Cousinhub

XLDnaute Barbatruc
Re : comment rendre une combobox plus rapide

Bonsoir,

Modifie ainsi le code "Exit" de ton Txtbox :

Code:
Private Sub txtCp_Exit(ByVal Cancel As MSForms.ReturnBoolean)
Dim Sh As Worksheet
Dim C As Range
Dim DerCol As Byte, I As Byte
Me.txtVille.Clear
Set Sh = Sheets("Code Postaux")
With Sh
    Set C = .Columns(1).Find(Me.txtCp, LookAt:=xlWhole)
    If Not C Is Nothing Then
        DerCol = .Cells(C.Row, 50).End(xlToLeft).Column
        For I = 2 To DerCol - 1
            Me.txtVille.AddItem C.Offset(, I)
        Next I
    End If
End With
triList
Me.txtVille.SetFocus
Me.txtVille.DropDown
Me.txtDépartement.Text = Sh.Cells(C.Row, 50)
Me.txtRégion.Text = Sh.Cells(C.Row, 51)
Me.txtPays.Text = Sh.Cells(C.Row, 52)
End Sub

Bonne soirée

Edit :

Ou plutôt ainsi, afin de conserver la gestion d'erreur, si un code postal n'existe pas...

Code:
Private Sub txtCp_Exit(ByVal Cancel As MSForms.ReturnBoolean)
Dim Sh As Worksheet
Dim C As Range
Dim DerCol As Byte, I As Byte
Me.txtVille.Clear
Set Sh = Sheets("Code Postaux")
With Sh
    Set C = .Columns(1).Find(Me.txtCp, LookAt:=xlWhole)
    If Not C Is Nothing Then
        DerCol = .Cells(C.Row, 50).End(xlToLeft).Column
        For I = 2 To DerCol - 1
            Me.txtVille.AddItem C.Offset(, I)
        Next I
        triList
        Me.txtVille.SetFocus
        Me.txtVille.DropDown
        Me.txtDépartement.Text = .Cells(C.Row, 50)
        Me.txtRégion.Text = .Cells(C.Row, 51)
        Me.txtPays.Text = .Cells(C.Row, 52)
    Else
        MsgBox "Le code postal " & Me.txtCp & " n'est pas répertorié!"
        Me.txtCp.Value = ""
        Exit Sub
    End If
End With
End Sub

Bonne soirée
 
Dernière édition:

snoopy07

XLDnaute Occasionnel
Re : comment rendre une combobox plus rapide

re

je viens de m apercevoir que depuis que j'ai changer mon code

quand je rentre un code postale entre 01000 et 09999 dans ma textbox j ai le message erreur code postal n'existe pas qui saffiche
alors que ses code sont bien dans ma liste

comment puis je rectifié cela

cordialement

Snoopy 07
 

Cousinhub

XLDnaute Barbatruc
Re : comment rendre une combobox plus rapide

Re-,

Peut-être ainsi :

Code:
Private Sub txtCp_Exit(ByVal Cancel As MSForms.ReturnBoolean)
Dim Sh As Worksheet
Dim C As Range
Dim DerCol As Byte, I As Byte
If Not IsNumeric(Me.txtCp) Then Exit Sub
Me.txtVille.Clear
Set Sh = Sheets("Code Postaux")
With Sh
    Set C = .Columns(1).Find(Val(Me.txtCp), LookAt:=xlWhole)
    If Not C Is Nothing Then
        DerCol = .Cells(C.Row, 50).End(xlToLeft).Column
        For I = 2 To DerCol - 1
            Me.txtVille.AddItem C.Offset(, I)
        Next I
        triList
        Me.txtVille.SetFocus
        Me.txtVille.DropDown
        Me.txtDépartement.Text = .Cells(C.Row, 50)
        Me.txtRégion.Text = .Cells(C.Row, 51)
        Me.txtPays.Text = .Cells(C.Row, 52)
    Else
        MsgBox "Le code postal " & Me.txtCp & " n'est pas répertorié!"
        Me.txtCp.Value = ""
        Exit Sub
    End If
End With
End Sub

Bonne nuit
 

Discussions similaires

Statistiques des forums

Discussions
311 725
Messages
2 081 947
Membres
101 849
dernier inscrit
florentMIG