Perte de focus après saisie de la première lettre

criscris11

XLDnaute Accro
Bonjour à tous,
J'espère que vous avez tous passé de bonnes vacances.

J'utilise dans un USF une recherche intuitive via un textbox mais je me suis rendu compte qu'après avoir saisie la première lettre, je perds le focus du textbox ce qui est embêtant car la recherche peut être réalisée sur plusieurs lettres ce qui m'oblige et recliquer dans le Textbox pour saisir la deuxième lettre.
Voici le code attaché :
Code:
'_______________________________________________________'
'A chaque changement dans la zone de recherche intuitive
'(mise à jour des zones de texte)
'_______________________________________________________'

Private Sub TextBox1_Change()
Dim xCell As Range, Nbr As Long, ligne As Long
Dim L As Byte

 Me.ListBox1.Clear
 Erase NomOK
 For Each xCell In Range(Sheets("Base gestion MDR").[F9], Sheets("Base gestion MDR").[F65000].End(xlUp))
   If UCase(xCell) Like UCase(Me.TextBox1) & "*" Then
      Me.ListBox1.AddItem
      Me.ListBox1.List(Me.ListBox1.ListCount - 1, 0) = xCell & " " & xCell.Offset(0, 1)
      ReDim Preserve NomOK(1 To Me.ListBox1.ListCount)
      NomOK(Me.ListBox1.ListCount) = xCell.Row
   End If
  Next xCell
   
If Me.ListBox1.ListCount > 0 Then
  Me.ListBox1.ListIndex = 0
  ligne = Me.ListBox1.ListIndex + 1
  Me.Label62.Caption = ListBox1.ListCount
  Me.TextBox2.Value = Sheets("Base gestion MDR").Cells(NomOK(ligne), "F")
  Me.TextBox3.Value = Sheets("Base gestion MDR").Cells(NomOK(ligne), "G")
  Me.TextBox4.Value = Sheets("Base gestion MDR").Cells(NomOK(ligne), "E")
  Repertoire = ThisWorkbook.Path
     If Dir(Repertoire & "\" & Me.TextBox4 & ".gif") <> "" Then
        Me.Image2.Picture = LoadPicture(Repertoire & "\" & Me.TextBox4 & ".gif")
     Else
        On Error Resume Next
        'Me.Image2.Picture = LoadPicture(Répertoire & "\" & "transparent.gif")'permet de rajouter un fond transparent pour les images autres qu'en format .gif
     End If
       
  Me.TextBox5.Value = Sheets("Base gestion MDR").Cells(NomOK(ligne), "W")
  Me.TextBox6.Value = Sheets("Base gestion MDR").Cells(NomOK(ligne), "C")
  Me.TextBox6.Value = Format(TextBox6.Value, "00"" ""000"" ""00000") 'format personnalisé identique aux cellules de la feuille de calcul
  Me.TextBox7.Value = Sheets("Base gestion MDR").Cells(NomOK(ligne), "B")
  Me.TextBox7.Value = Format(TextBox7.Value, "00000000")
  Me.TextBox8.Value = Sheets("Base gestion MDR").Cells(NomOK(ligne), "D")
  If Dir(Repertoire & "\" & Me.TextBox8 & ".gif") <> "" Then
        Me.Image3.Picture = LoadPicture(Repertoire & "\" & Me.TextBox8 & ".gif")
     ElseIf Me.TextBox8.Value = "BCL/GARDE" Then
        Me.Image3.Picture = LoadPicture(Repertoire & "\" & "BCL" & ".gif")
     ElseIf Me.TextBox8.Value = "PASS/FANFARE" Or Me.TextBox8.Value = "FI" Then
     Me.Image3.Picture = LoadPicture(Repertoire & "/" & "Transparent" & ".gif")
        On Error Resume Next
        'Me.Image3.Picture = LoadPicture(Répertoire & "\" & "transparent.gif")'permet de rajouter un fond transparent pour les images autres qu'en format .gif
     End If
  Me.TextBox9.Value = Sheets("Base gestion MDR").Cells(NomOK(ligne), "H")
  Me.TextBox10.Value = Sheets("Base gestion MDR").Cells(NomOK(ligne), "I")
  Me.TextBox11.Value = Sheets("Base gestion MDR").Cells(NomOK(ligne), "L")
  Me.TextBox12.Value = Sheets("Base gestion MDR").Cells(NomOK(ligne), "K")
  Me.TextBox13.Value = Sheets("Base gestion MDR").Cells(NomOK(ligne), "M")
  Me.TextBox14.Value = Sheets("Base gestion MDR").Cells(NomOK(ligne), "Q")
  Me.TextBox15.Value = Sheets("Base gestion MDR").Cells(NomOK(ligne), "R")
  Me.TextBox16.Value = Sheets("Base gestion MDR").Cells(NomOK(ligne), "S")
  Me.TextBox17.Value = Sheets("Base gestion MDR").Cells(NomOK(ligne), "V")
  Me.TextBox20.Value = Sheets("Base gestion MDR").Cells(NomOK(ligne), "Y")
  Me.TextBox21.Value = Sheets("Base gestion MDR").Cells(NomOK(ligne), "X")
  Me.TextBox23.Value = Me.TextBox21.Value + 1
  Me.TextBox24.Value = Sheets("Base gestion MDR").Cells(NomOK(ligne), "AL")
  Me.TextBox25.Value = Sheets("Base gestion MDR").Cells(NomOK(ligne), "AM")
  Me.Label34.Caption = Sheets("Base gestion MDR").Cells(NomOK(ligne), "AN")
  Me.Label36.Caption = Sheets("Base gestion MDR").Cells(NomOK(ligne), "AO")
  Me.TextBox26.Value = Sheets("Base gestion MDR").Cells(NomOK(ligne), "AF")
  If TextBox26.Value <= CDate(Date) Then
  TextBox26.BackColor = RGB(255, 0, 0)
  Me.CommandButton9.Visible = True
  ElseIf TextBox26.Value >= CDate(Date) + 1 And TextBox26.Value <= CDate(Date) + 7 Then
  TextBox26.BackColor = RGB(255, 102, 0)
  Me.CommandButton9.Visible = False
  Else
  TextBox26.BackColor = RGB(255, 255, 255)
  Me.CommandButton9.Visible = False
  End If
  Me.TextBox27.Value = Sheets("Base gestion MDR").Cells(NomOK(ligne), "AG")
  Me.Label40.Caption = Sheets("Base gestion MDR").Cells(NomOK(ligne), "AH")
  Me.Label42.Caption = Sheets("Base gestion MDR").Cells(NomOK(ligne), "AI")
  Me.TextBox29.Value = Sheets("Base gestion MDR").Cells(NomOK(ligne), "AQ")
  Me.TextBox30.Value = Sheets("Base gestion MDR").Cells(NomOK(ligne), "AS")
  Me.TextBox31.Value = Sheets("Base gestion MDR").Cells(NomOK(ligne), "BB")
  If TextBox31.Value = "TDM" Then
  TextBox31.BackColor = RGB(0, 0, 255) 'fond bleu marine si TDM
  TextBox31.ForeColor = RGB(255, 255, 0) 'couleur de police jaune (or) si TDM
  Else
  TextBox31.BackColor = RGB(255, 255, 255) 'fond blanc si différent de TDM
  TextBox31.ForeColor = RGB(0, 0, 0) 'couleur de police noire si différent de TDM
  End If
  Me.TextBox32.Value = Sheets("Base gestion MDR").Cells(NomOK(ligne), "BD")
  Me.TextBox33.Value = Sheets("Base gestion MDR").Cells(NomOK(ligne), "BH")
  Me.TextBox34.Value = Sheets("Base gestion MDR").Cells(NomOK(ligne), "BE")
  Me.TextBox35.Value = Sheets("Base gestion MDR").Cells(NomOK(ligne), "BF")
  Me.TextBox36.Value = Sheets("Base gestion MDR").Cells(NomOK(ligne), "BG")
  Me.TextBox37.Value = Sheets("Base gestion MDR").Cells(NomOK(ligne), "AT")
  If Sheets("Base gestion MDR").Cells(NomOK(ligne), "AW") = "F" Then
  Me.TextBox38.Value = "Féminin"
  Me.TextBox38.BackColor = RGB(255, 153, 204)
  Else
  Me.TextBox38.Value = "Masculin"
  Me.TextBox38.BackColor = RGB(153, 204, 255)
  End If
  Me.TextBox39.Value = Sheets("Base gestion MDR").Cells(NomOK(ligne), "AU")
  Me.TextBox40.Value = Sheets("Base gestion MDR").Cells(NomOK(ligne), "AV")
  Label57.Caption = "ans"
  Me.TextBox41.Value = Sheets("Base gestion MDR").Cells(NomOK(ligne), "AX")
  Me.TextBox42.Value = Sheets("Base gestion MDR").Cells(NomOK(ligne), "AZ")
  Me.TextBox43.Value = Sheets("Base gestion MDR").Cells(NomOK(ligne), "BA")
  
  'Me.Label77.Caption = Sheets("Base gestion MDR").Cells(NomOK(ligne), "BQ")
   For L = 1 To 6
        With Me.Controls("Label" & 63 + L)
            .Caption = Sheets("Base gestion MDR").Cells(NomOK(ligne), 60 + L)
            Select Case .Caption
            Case "Oui"
                .BackColor = RGB(0, 255, 0)
            Case "Ajourné"
                .BackColor = RGB(255, 102, 0)
            Case "Abandon", "Echec"
                .BackColor = RGB(255, 0, 0)
            Case Else
                .BackColor = RGB(255, 255, 255)
                .Caption = "Non"
            End Select
        End With
    Next L
   If Sheets("Base gestion MDR").Cells(NomOK(ligne), "N") = "" And Sheets("Base gestion MDR").Cells(NomOK(ligne), "P") = "" Then
   Label75.Caption = "Période probatoire terminée"
   Label75.BackColor = RGB(0, 255, 0)
   Label75.Height = 20
   ElseIf CDate(Sheets("Base gestion MDR").Cells(NomOK(ligne), "N")) > CDate(Date) Then
   Label75.Caption = "Fin de la période probatoire le" & " " & Sheets("Base gestion MDR").Cells(NomOK(ligne), "N")
   Label75.BackColor = RGB(255, 102, 0)
   Label75.Height = 20
   ElseIf Sheets("Base gestion MDR").Cells(NomOK(ligne), "P") <> "" Then
   Label75.Caption = "Période probatoire renouvelée pour" & " " & Sheets("Base gestion MDR").Cells(NomOK(ligne), "O") & " " & "jusqu'au" & " " & Sheets("Base gestion MDR").Cells(NomOK(ligne), "P")
   Label75.BackColor = RGB(255, 0, 0)
   Label75.Height = 42
   End If
End If

ListBox1_Change

End Sub

Merci de bien vouloir me dire pourquoi je perds le focus.
Bonne rentrée et bonne journée à tous.
 

Papou-net

XLDnaute Barbatruc
Re : Perte de focus après saisie de la première lettre

Bonjour criscris11,

Pour répondre à ta question : parce que...

Tu dois savoir déjà que, passé 3-4 lignes de code,il devient trop fastidieux de chercher l'origine d'un problème!

Il serait donc utile que tu joignes un fichier reproduisant le problème, ne crois-tu pas?

A te lire.

Cordialement.
 
Dernière édition:

criscris11

XLDnaute Accro
Re : Perte de focus après saisie de la première lettre

Bonjour Papou-net,
Merci de te pencher sur mon problème. Pour ce qui est d'envoyer un fichier, il va falloir que j'y aille à coup de tronçonneuse car il fait environ 6 Mo : je vais essayer d'extraire le minimum et d'envoyer l'extraction.
Bon après-midi.

PS : le problème pourrait-il venir d'un autre code : dans ce cas là, il faudrait que je laisse les code entier du USF ?
 

Robert

XLDnaute Barbatruc
Re : Perte de focus après saisie de la première lettre

Bonjour le fil, bonjour le forum,

Même constat que Papou-net. Peut-être en faisant tourner ta macro pas à pas. Tu mets un point d'arrêt sur la première ligne du code, tu lance la macro puis tu avances ligne par ligne avec la touche [F8]. Sinon egarde aussi du coté des propriétés AutoTab et MaxLength de la Textbox. Car en combinant les deux True et 1 on peut perdre le focus dès que le premier caractère est édité...
 

criscris11

XLDnaute Accro
Re : Perte de focus après saisie de la première lettre

Re,
Cela ne marche pas même avec le TextBox1.SetFocus avant le End Sub.

En regardant le problème de plus près, la perte de focus intervient quand la ListBox d'affichage change et en voici le code (moins long) :eek: :
Code:
Private Sub ListBox1_Change()
Dim ligne As Long
If ListBox1.ListIndex < 0 Then
  Label30 = "":  Me.TextBox2 = "":  Me.TextBox3 = "":  Me.TextBox4 = ""
Else
  ligne = Me.ListBox1.ListIndex + 1
  If Cells(NomOK(ligne), "E") = "SDT" And IsDate(Cells(NomOK(ligne), "Z")) Then
    Label30 = "Elévation à la distinction de première classe à compter du " & Cells(NomOK(ligne), "Z")
    Label30.BackColor = &HC000&
  ElseIf Cells(NomOK(ligne), "E") = "1CL" And Cells(NomOK(ligne), "AA") = "Oui" Then
    Label30 = "Remplit les conditions pour l'avancement au grade de caporal"
    Label30.BackColor = &H80FF&
  ElseIf Cells(NomOK(ligne), "E") = "CPL" And Cells(NomOK(ligne), "AB") = "Oui" Then
    Label30 = "Remplit les conditions pour l'avancement au grade de caporal-chef"
    Label30.BackColor = &H80FF&
  ElseIf Cells(NomOK(ligne), "E") = "CCH" And IsDate(Cells(NomOK(ligne), "AC")) Then
    Label30 = "Elévation à la distinction de caporal-chef de première classe à compter du " & Cells(NomOK(ligne), "AC")
    Label30.BackColor = &HC000&
  Else
    Label30 = ""
    Label30.BackColor = &HFFFFFF
  End If
End If
End Sub

Je vais essayer d'être plus clair : je tape la première lettre et je perds le focus car la liste a "bougée", je reprends le focus et tape la deuxième lettre et là 2 cas de figures ; si la liste ne bouge pas, je garde le focus et si la liste bouge je reperds le focus.
Je vais essayer de vous faire un petit exemple d'après mon fichier sur une dizaine de noms.
 

criscris11

XLDnaute Accro
Re : Perte de focus après saisie de la première lettre

Re,
Au départ j'ai ma liste qui s'initialise par rapport à mes noms qui ne sont pas toujours dans l'ordre alphabétique suivant le tri dans l'onglet source.
Je recherche mon nom par exemple (je vais prendre mon prénom cela sera plus simple) donc je tape "C" dans le Textbox donc je perds le focus. La liste se réduit avec tous mes noms commençant par C. Je reprends le focus et je tape "H" après le "C" : si la première occurrence de la liste commence par "CH" je garde le focus sinon je le perds. Voilà en espérant avoir été un peu plus explicite : pb de tri ou d'ordre dans la ListBox ?

Bon après-midi.
 

Robert

XLDnaute Barbatruc
Re : Perte de focus après saisie de la première lettre

Bonjour le fil, bonjour le forum,

Pourquoi ne pas effectuer la totalité du code uniquement quand la recherche est effectuée ? À la sotie de la TextBox1 par exemple. Ça éviterait de faire tous les changements chaque fois que tu rajoutes une lettre...
En pièce jointe un exemple tout simple pour te guider...
 

Pièces jointes

  • Criscris_v01.xls
    45 KB · Affichages: 89

criscris11

XLDnaute Accro
Re : Perte de focus après saisie de la première lettre

Re à tous,
Ok et merci Robert. Je faire des essais et essayer de simplifier au mieux le code en fonction de tes conseils.
Je vous tiendrai au courant de toute façon.

Encore merci à tous et bonne soirée.
 

criscris11

XLDnaute Accro
Re : Perte de focus après saisie de la première lettre

Bonsoir à tous,

Comme promis, je viens aux nouvelles. J'ai réussi en partie à modifier mes codes pour arriver à mes fins grâce à tous vos conseils.
Mais de mon côté (car j'en ai marre de chiner des codes à droite à gauche), je me suis dégoté de derrière les fagots (et le mot est faible) l'excellente bible de Mr Spreedcheet (pour ne pas nommer John Walkenbach) "VBA pour Excel 2003". Quand je disais de derrière les fagots : rupture chez l'éditeur, plus aucun exemplaire dans les librairies mêmes spécialisées... et puis j'ai trouvé un exemplaire (en français en plus) d'occasion (un seul sur toute la toile).
Donc maintenant plus d'excuses mais la route va être longue à la vue des 1000 pages que contient cette bible mais je savais à quoi m'attendre et puis il n'est jamais trop tard pour apprendre, non ?
Bon je vais vous laisser car j'ai quelques nuits blanches qui m'attendent.
En tous cas, encore merci à toutes et à tous pour votre entraide chaleureuse.
Bonne soirée et au plaisir.
 

criscris11

XLDnaute Accro
Re : Perte de focus après saisie de la première lettre

Bonjour à tous,

Suite à ce post et les bons conseils des intervenants, j'ai revu les codes mais je sèche sur un point : en fait c'est un problème de mise à jour sur l'évènement ListBox_Change (enfin je suppose).
J'ai pu extraire une petite partie des données afin de concocter un petit fichier ou le problème est expliqué.

Merci d'avance et bonne soirée à tous.
 

Pièces jointes

  • Pb MAJ ListBox_Click.xls
    89.5 KB · Affichages: 70

Statistiques des forums

Discussions
294 444
Messages
1 938 548
Membres
188 924
dernier inscrit
TFT