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
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: