Extraction de listbox. Résolu

Question

Bonjour, je suis un peu moins que débutant en VBA et j'ai besoin de vos services.
Je suis bénévole dans une association et je dois gérer les adhérents. J'ai un tableau de 21 colonnes avec lesquelles une listbox1 me fait une liste en fonction du choix d'un critère. Pour l'instant, tout cela fonctionne
J'ai également une userform "ADHERENTS" dont les champs sont également alimentés par la feuille de 21 colonnes pour les mises à jour ou autre.
Je voudrais que 2 choses se passent lorsque je sélectionne une ligne dans la listbox (pas forcément simultanément).
1- les colones étant trop nombreuses pour être imprimées sur une feuille, ma sélection soit imprimée sous forme de 2 colonnes, l'une correspondant aux entêtes de colonnes et l'autre à la sélection dans la listbox.
2-Que l'userform "ADHERENTS" s'ouvre avec les champs complétés par la sélection de la listbox1.
J'en demande peut être beaucoup, en tous cas un énorme merci si vous me rendez ce service.

fabien25000 · Answer

Bonsoir,
un fichier exemple pour illustrer peut aider à mieux comprendre le besoin (surtout pour le premier point)
pour afficher l'userform"Adherants" remplis, une boucle devrait faire l'affaire ;)

TitiPointCom67 · Answer

Qu'entendez-vous par fichier exemple ?
Dois-je joindre le code déjà existant ?

TitiPointCom67 · Answer

Ceci est le code de l'userform contenant la Listbox Private Sub UserForm_Initialize() Set f = Sheets("INSCRIPTIONS") Set Rng = f.Range("A2:U" & f.[a65000].End(xlUp).Row) bd = Rng.Value ' BD dans un Array pour rapidié Ncol = Rng.Columns.Count titre = Application.Index(Rng.Offset(-1).Value, 1) ' Titres de la BD Me.ComboBox1.List = titre bd = Rng.Value Me.ListBox1.List = bd '--- titres ListBox x = 10 y = Me.ListBox1.Top - 12 For i = 1 To Ncol Set Lab = Me.Controls.Add("Forms.Label.1") Lab.Caption = f.Cells(1, i) Lab.Top = y Lab.Left = x + 5 x = x + f.Columns(i).Width * 0.8 temp = temp & f.Columns(i).Width * 0.8 & ";" Next Me.ListBox1.ColumnWidths = temp Me.ListBox1.ColumnCount = Ncol Me.Label4.Caption = Me.ListBox1.ListCount & " Ligne(s)" End Sub Private Sub ComboBox1_Change() ' choix de la colonne de recherche If IsNumeric(Me.ComboBox1) Then tmp = Val(Me.ComboBox1) Else tmp = Me.ComboBox1 colClé = Application.Match(tmp, titre, 0) Me.Label2.Caption = Me.ComboBox1 Set d1 = CreateObject("Scripting.Dictionary") For i = LBound(bd) To UBound(bd) ' liste des choix de la colonne choisie sans doublons d1(bd(i, colClé)) = "" Next i choix = d1.keys: Tri choix, LBound(choix), UBound(choix) ComboBox2.List = choix End Sub Private Sub ComboBox2_click() ' alimentation ListBox If IsNumeric(Me.ComboBox2) Then clé2 = Val(Me.ComboBox2) Else clé2 = Me.ComboBox2 Me.ListBox1.Column = FiltreMultiColTransp(bd, clé2, colClé) Me.Label4.Caption = Me.ListBox1.ListCount & " Ligne(s)" End Sub Private Sub ComboBox2_DblClick(ByVal Cancel As MSForms.ReturnBoolean) ComboBox2.List = choix Me.ComboBox2.DropDown End Sub Function FiltreMultiColTransp(Tbl, clé, colClé) Ncol = UBound(Tbl, 2) Dim b(): n = 0 For i = LBound(Tbl) To UBound(Tbl) If clé = Tbl(i, colClé) Then n = n + 1: ReDim Preserve b(1 To Ncol, 1 To n) For k = 1 To Ncol: b(k, n) = Tbl(i, k): Next k End If Next i If n > 0 Then FiltreMultiColTransp = b End Function Sub Tri(a, gauc, droi) ' Quick sort ref = a((gauc + droi) \ 2) g = gauc: d = droi Do Do While a(g) < ref: g = g + 1: Loop Do While ref < a(d): d = d - 1: Loop If g <= d Then temp = a(g): a(g) = a(d): a(d) = temp g = g + 1: d = d - 1 End If Loop While g <= d If g < droi Then Tri a, g, droi If gauc < d Then Tri a, gauc, d Me.Label4.Caption = Me.ListBox1.ListCount & " Ligne(s)" End Sub Ceci est le code de l'userform contenant les champs


'*********************************************************************
' Bouton Liste NOMS par N° ADHERENTS
'**********************************************************************

Private Sub CommandButton1_Click()
UserForm3.Hide
UserForm5.Show 1
End Sub
'******************************************************************
'Bouton Listes NOMS par COMMUNES
'******************************************************************

Private Sub CommandButton2_Click()
UserForm3.Hide
UserForm6.Show 1
End Sub

Private Sub INSCRIPTIONS_Click()
Sheets("INSCRIPTIONS").Activate    'Ouvre la feuille
ActiveSheet.Shapes("Image 4").Visible = False       'Rend invisible le logo
ActiveSheet.Shapes("Rectangle 3").Visible = False   'Rend invisible le rectangle blanc pour afficher les données
    Range("A1").Select              'Se place sur la cellule A1
    Unload Me
End Sub

'******************************************************************
'Bouton Listes codes
'******************************************************************

Private Sub ListeNoms_Click()
UserForm3.Hide
UserForm9.Show 1
End Sub

'*********************************************************************
' Bouton Suivant
'**********************************************************************
Private Sub SUIVANT_Click()
If ActiveCell.Offset(1, 0) = "" Then        'Si le curseur se retrouve sur la dernier ligne du tableau
MsgBox "Dernier enregistrement atteint", vbInformation, "Gestion INSCRIPTIONS"
Else                                        'affiche un message pour le signaler
ActiveCell.Offset(1, 0).Select              'si non va su la ligne suivante
Mon_text
End If

Dim Nblign As Integer
Label8.Caption = Range("A657893").End(xlUp).Row - 1     'affiche le nombre total d'enregistrements
Nblign = ActiveCell.Row - 1                             'et le N° de l'enregistrement actif
Label6.Caption = Nblign
End Sub

Private Sub UserForm_Click()

End Sub

'*********************************************************************
' Fontion permettant d'afficher dans les champs les données de la base
'**********************************************************************

Private Function Mon_text()
TextBox1.Text = ActiveCell.Text
TextBox2.Text = ActiveCell.Offset(0, 1).Text
If ActiveCell.Offset(0, 2).Text = "H" Then SexH = True Else SexH = False
If ActiveCell.Offset(0, 3).Text = "F" Then SexF = True Else SexF = False
TextBox3.Text = ActiveCell.Offset(0, 4).Text
If ActiveCell.Offset(0, 5).Text = "" Then TextBox4.Text = "" Else TextBox4.Text = CDate(ActiveCell.Offset(0, 5).Text)
TextBox5.Text = ActiveCell.Offset(0, 6).Text
TextBox6.Text = ActiveCell.Offset(0, 7).Text
TextBox7.Text = ActiveCell.Offset(0, 8).Text
TextBox8.Text = ActiveCell.Offset(0, 9).Text
TextBox9.Text = ActiveCell.Offset(0, 10).Text
TextBox10.Text = ActiveCell.Offset(0, 11).Text
TextBox11.Text = ActiveCell.Offset(0, 12).Text
ComboBox1.Value = ActiveCell.Offset(0, 13).Text
ComboBox2.Value = ActiveCell.Offset(0, 14).Text
ComboBox3.Value = ActiveCell.Offset(0, 15).Text
If ActiveCell.Offset(0, 16).Text = "C" Then VerC = True Else VerC = False
If ActiveCell.Offset(0, 17).Text = "N" Then VerN = True Else VerN = False
TextBox15.Text = ActiveCell.Offset(0, 18).Text
If ActiveCell.Offset(0, 19).Text = "" Then TextBox16.Text = "" Else TextBox16.Text = CDate(ActiveCell.Offset(0, 19).Text)
TextBox17.Text = ActiveCell.Offset(0, 20).Text

End Function

'********************************************************************
'INITIALISATION DU FORMULAIRE
'********************************************************************

Private Sub UserForm_Initialize()

Sheets("INSCRIPTIONS").Activate       'Désigne la feuille où se trouve la base de donnée
ActiveSheet.Shapes("Rectangle 3").Visible = True    'Affiche le rectangle blanc qui cache les dommées
ActiveSheet.Shapes("Image 4").Visible = True        'Affiche le logo sur le rectangle blanc
Cells(2, 1).Select                     'se place sur la première ligne de données
TextBox1.Text = Cells(2, 5)            'affiche le contenue de la ligne dans les champs du formulaire
TextBox2.Text = Cells(2, 2)
If Cells(2, 3) = "H" Then SexH = True Else SexH = False
If Cells(2, 4) = "F" Then SexF = True Else SexF = False
TextBox3.Text = Cells(2, 5)
TextBox4.Text = Cells(2, 6)
TextBox5.Text = Cells(2, 7)
TextBox6.Text = Cells(2, 8)
TextBox7.Text = Cells(2, 9)
TextBox8.Text = Cells(2, 10)
TextBox9.Text = Cells(2, 11)
TextBox10.Text = Cells(2, 12)
TextBox11.Text = Cells(2, 13)
ComboBox1.Value = Cells(2, 14)
ComboBox2.Value = Cells(2, 15)
ComboBox3.Value = Cells(2, 16)
TextBox15.Text = Cells(2, 17)
If Cells(2, 8) = "C" Then VerC = True Else VerC = False
If Cells(2, 19) = "N" Then VerN = True Else VerN = False
TextBox16.Text = Cells(2, 20)
TextBox17.Text = Cells(2, 21)

Dim Nblign As Integer
Label8.Caption = Range("A657893").End(xlUp).Row - 1 'Affiche le nombre d'enregistrements
Nblign = ActiveCell.Row - 1                         'et le N° de la ligne active
Label6.Caption = Nblign

If ActiveCell.Offset(1, 0) = "" Then
MsgBox "Dernier enregistrement atteint"
Else
ActiveCell.Offset(1, 0).Select
Mon_text
End If

Label8.Caption = Range("A657893").End(xlUp).Row - 1
Nblign = ActiveCell.Row - 1
Label6.Caption = Nblign

If ActiveCell.Offset(-1, 0) = "NOM" Then
MsgBox "Premier enregistrement atteint"
Else
ActiveCell.Offset(-1, 0).Select
Mon_text
End If

Label8.Caption = Range("A657893").End(xlUp).Row - 1
Nblign = ActiveCell.Row - 1
Label6.Caption = Nblign


With Me.ComboBox1
ComboBox1.AddItem "B200"
ComboBox1.AddItem "B201"
ComboBox1.AddItem "B202"
ComboBox1.AddItem "B203"
ComboBox1.AddItem "B204"
ComboBox1.AddItem "B205"
ComboBox1.AddItem "B206"
ComboBox1.AddItem "B220"
ComboBox1.AddItem "B221"
ComboBox1.AddItem "B222"
ComboBox1.AddItem "B230"
ComboBox1.AddItem "B235"
ComboBox1.AddItem "B240"
ComboBox1.AddItem "B241"
ComboBox1.AddItem "B242"
ComboBox1.AddItem "B243"
ComboBox1.AddItem "B260"
ComboBox1.AddItem "B261"
ComboBox1.AddItem "B262"
ComboBox1.AddItem "B270"
ComboBox1.AddItem "B271"
ComboBox1.AddItem "B272"
ComboBox1.AddItem "B301"
ComboBox1.AddItem "B302"
ComboBox1.AddItem "B303"
ComboBox1.AddItem "B304"
ComboBox1.AddItem "B320"
ComboBox1.AddItem "B321"
ComboBox1.AddItem "B330"
ComboBox1.AddItem "B331"
ComboBox1.AddItem "B332"
ComboBox1.AddItem "B333"
ComboBox1.AddItem "B334"
ComboBox1.AddItem "B340"
ComboBox1.AddItem "B341"
ComboBox1.AddItem "B342"
ComboBox1.AddItem "B355"
ComboBox1.AddItem "B356"
ComboBox1.AddItem "B360"
ComboBox1.AddItem "B361"
ComboBox1.AddItem "B362"
ComboBox1.AddItem "B370"
ComboBox1.AddItem "B371"
ComboBox1.AddItem "B375"
ComboBox1.AddItem "B376"
ComboBox1.AddItem "B377"
ComboBox1.AddItem "B378"
ComboBox1.AddItem "B379"
End With

With Me.ComboBox2
ComboBox2.AddItem "B200"
ComboBox2.AddItem "B201"
ComboBox2.AddItem "B202"
ComboBox2.AddItem "B203"
ComboBox2.AddItem "B204"
ComboBox2.AddItem "B205"
ComboBox2.AddItem "B206"
ComboBox2.AddItem "B220"
ComboBox2.AddItem "B221"
ComboBox2.AddItem "B222"
ComboBox2.AddItem "B230"
ComboBox2.AddItem "B235"
ComboBox2.AddItem "B240"
ComboBox2.AddItem "B241"
ComboBox2.AddItem "B242"
ComboBox2.AddItem "B243"
ComboBox2.AddItem "B260"
ComboBox2.AddItem "B261"
ComboBox2.AddItem "B262"
ComboBox2.AddItem "B270"
ComboBox2.AddItem "B271"
ComboBox2.AddItem "B272"
ComboBox2.AddItem "B301"
ComboBox2.AddItem "B302"
ComboBox2.AddItem "B303"
ComboBox2.AddItem "B304"
ComboBox2.AddItem "B320"
ComboBox2.AddItem "B321"
ComboBox2.AddItem "B330"
ComboBox2.AddItem "B331"
ComboBox2.AddItem "B332"
ComboBox2.AddItem "B333"
ComboBox2.AddItem "B334"
ComboBox2.AddItem "B340"
ComboBox2.AddItem "B341"
ComboBox2.AddItem "B342"
ComboBox2.AddItem "B355"
ComboBox2.AddItem "B356"
ComboBox2.AddItem "B360"
ComboBox2.AddItem "B361"
ComboBox2.AddItem "B362"
ComboBox2.AddItem "B370"
ComboBox2.AddItem "B371"
ComboBox2.AddItem "B375"
ComboBox2.AddItem "B376"
ComboBox2.AddItem "B377"
ComboBox2.AddItem "B378"
ComboBox2.AddItem "B379"
End With

With Me.ComboBox3
ComboBox3.AddItem "B200"
ComboBox3.AddItem "B201"
ComboBox3.AddItem "B202"
ComboBox3.AddItem "B203"
ComboBox3.AddItem "B204"
ComboBox3.AddItem "B205"
ComboBox3.AddItem "B206"
ComboBox3.AddItem "B220"
ComboBox3.AddItem "B221"
ComboBox3.AddItem "B222"
ComboBox3.AddItem "B230"
ComboBox3.AddItem "B235"
ComboBox3.AddItem "B240"
ComboBox3.AddItem "B241"
ComboBox3.AddItem "B242"
ComboBox3.AddItem "B243"
ComboBox3.AddItem "B260"
ComboBox3.AddItem "B261"
ComboBox3.AddItem "B262"
ComboBox3.AddItem "B270"
ComboBox3.AddItem "B271"
ComboBox3.AddItem "B272"
ComboBox3.AddItem "B301"
ComboBox3.AddItem "B302"
ComboBox3.AddItem "B303"
ComboBox3.AddItem "B304"
ComboBox3.AddItem "B320"
ComboBox3.AddItem "B321"
ComboBox3.AddItem "B330"
ComboBox3.AddItem "B331"
ComboBox3.AddItem "B332"
ComboBox3.AddItem "B333"
ComboBox3.AddItem "B334"
ComboBox3.AddItem "B340"
ComboBox3.AddItem "B341"
ComboBox3.AddItem "B342"
ComboBox3.AddItem "B355"
ComboBox3.AddItem "B356"
ComboBox3.AddItem "B360"
ComboBox3.AddItem "B361"
ComboBox3.AddItem "B362"
ComboBox3.AddItem "B370"
ComboBox3.AddItem "B371"
ComboBox3.AddItem "B375"
ComboBox3.AddItem "B376"
ComboBox3.AddItem "B377"
ComboBox3.AddItem "B378"
ComboBox3.AddItem "B379"
End With


End Sub

'********************************************************************
'BOUTON TABLEAU DE BORD
'********************************************************************

Private Sub TABLEAU_BORD_Click()
    Sheets("TABLEAU_DE_BORD").Activate      'Ouvre la feuille
    Range("A1").Select                      'se place sur la cellule A1
    Unload Me                               'ferme le formulaire
End Sub

'********************************************************************
'BOUTON SUPRESSION
'********************************************************************

Private Sub Suppression_Click()         'affiche un message demandant confirmation
r = MsgBox(" Confirmez-vous la suppression ? ", vbYesNo + vbInformation, "Gestion INSCRIPTIONS")
If r <> 6 Then Exit Sub                 'si OK, efface la ligne de données dans la base de données
Selection.EntireRow.Delete
End Sub

'************************************************************************
'BOUTON ENREGISTRER & QUITTER
'************************************************************************

Public Sub QUITTER_Click()
Dim wb As Workbook
Dim response As String
    response = MsgBox(" Souhaitez vous vraiment quitter Excel ? ", vbYesNo + vbCritical, "Quitter Excel")
    Select Case response                    ' Si OUI
        Case vbYes                          ' Recherche toutes les applications ouvertes
            Sheets("TABLEAU_DE_BORD").Activate          'Ouvre la feuille TABLEAU DE BORD avant de quitter
            For Each wb In Application.Workbooks
                If wb.Name <> ThisWorkbook.Name Then    'Ferme toutes les applications sauf celle active
                    wb.Close True                       'Les enregistre
                End If
            Next
            Application.Quit                            'Et les ferme
            ThisWorkbook.Close True                     ' puis fait de même pour l'application active

        Case vbNo                              'Si NON
            Set wb = Nothing                    'Ne fait rien
            Exit Sub
    End Select

End Sub

'************************************************************************
'BOUTON PREMIER
'************************************************************************

Private Sub PREM_Click()
Cells(2, 1).Select              'Se place sur la première ligne de la base de données
TextBox1.Text = Cells(2, 1)     'et affiche son contenu sur le formulaire
Mon_text

Dim Nblign As Integer
Label8.Caption = Range("A657893").End(xlUp).Row - 1     'affiche le nombre total d'enregistrements
Nblign = ActiveCell.Row - 1                             'et le N° de l'enregistrement actif
Label6.Caption = Nblign

End Sub

'*************************************************************************
' Bouton PRECEDENT
'*************************************************************************

Private Sub PRECED_Click()                    'Si le curseur se retrouve sur la première ligne du tableau
If ActiveCell.Offset(-1, 0) = "NOM" Then   'affiche un message pour le signaler
MsgBox "Premier enregistrement atteint", vbInformation, "Gestion CODES"
Else
ActiveCell.Offset(-1, 0).Select                'si non va su la ligne précédente
Mon_text
End If

Dim Nblign As Integer
Label8.Caption = Range("A657893").End(xlUp).Row - 1     'affiche le nombre total d'enregistrements
Nblign = ActiveCell.Row - 1                             'et le N° de l'enregistrement actif
Label6.Caption = Nblign


End Sub

'****************************************************************
' Vide les champs du formulaire
'****************************************************************

Private Sub Effacer_Click()         'Efface le contenu des champs du formulaire
TextBox1.Text = ""                  'mais pas l'enregistrement affiché qui se trouve dans la base de données
TextBox2.Text = ""
TextBox3.Text = ""
SexH = False
SexF = True
TextBox4.Text = "jj/mm/aaaa"
TextBox5.Text = ""
TextBox6.Text = ""
TextBox7.Text = ""
TextBox8.Text = ""
TextBox9.Text = ""
TextBox10.Text = ""
TextBox11.Text = ""
ComboBox1.Value = ""
ComboBox2.Value = ""
ComboBox3.Value = ""
TextBox15.Text = ""
VerC = True
VerN = False
TextBox16.Text = "jj/mm/aaaa"
TextBox17.Text = ""

TextBox1.SetFocus                       'se place sur le premier champ du formulaire

[A65675].End(xlUp).Offset(1, 0).Select    '.....se placer sur la derniere cellule du tableau

End Sub


'*********************************************************************
'Bouton Dernier enregistrement
'*********************************************************************

Private Sub DERN_Click()
rr = [A657893].End(xlUp).Row                        'Le curseur se rend sur la dernière ligne de la base de données
Cells(rr, 1).Select                                 'et le formulaire affiche le dernier enregitrement
TextBox1.Text = Cells(rr, 1)
Mon_text

Dim Nblign As Integer
Label8.Caption = Range("A657893").End(xlUp).Row - 1 'Le N° du dernier enregistrement est affiché
Nblign = ActiveCell.Row - 1
Label6.Caption = Nblign


End Sub

'********************************************************************
' Ouvre la feuille de données DONNEES_CODES
' avec le bouton DONNEES_CODES du formulaire
'*******************************************************************

Private Sub DONNEES_CODES_Click()
Sheets("DONNEES_CODES").Activate    'Ouvre la feuille
ActiveSheet.Shapes("Image 2").Visible = False       'Rend invisible le logo
ActiveSheet.Shapes("Rectangle 1").Visible = False   'Rend invisible le rectangle blanc pour afficher les données
    Range("A1").Select              'Se place sur la cellule A1
    Unload Me                       'ferme le formulaire
End Sub


'************************************************************************
'AJOUT d'une ligne de données dans la base
'************************************************************************

Private Sub Ajout_Click()
Dim i As Integer
                                                                     
Cells(ActiveCell.Row, 1) = UCase(TextBox1.Text)
Cells(ActiveCell.Row, 2) = TextBox2.Text                          'Ucase Converti les minuscules en majuscules
If SexH = True Then SexF = False
If SexH = True Then Cells(ActiveCell.Row, 3) = "H" Else Cells(ActiveCell.Row, 3) = ""
If SexF = True Then SexH = False
If SexF = True Then Cells(ActiveCell.Row, 4) = "F" Else Cells(ActiveCell.Row, 4) = ""

'For i = 2 To Range("a:a").End(xlDown).Row                               'Si le N° entré existe déjà.
'If Cells(i, 5).Text = "" Then Cells(i, 5) = "" Else If Cells(i, 5) = TextBox3.Text Then MsgBox _
'"Ce N° d'adhérent est déjà attribué à " & Cells(i, 1).Value & " " & _
'Cells(i, 2).Value: TextBox3.Text = " ": TextBox1.SetFocus: Exit Sub      'Si oui il stope la procédure et affiche un message
'Next i
Cells(ActiveCell.Row, 5) = TextBox3.Text

If TextBox4.Text = "jj/mm/aaaa" Or TextBox16.Text = "" Then Cells(ActiveCell.Row, 6) = "" Else Cells(ActiveCell.Row, 6) = CDate(TextBox4.Text)
Cells(ActiveCell.Row, 7) = TextBox5.Text
If Cells(ActiveCell.Row, 8) <> "" Then Cells(ActiveCell.Row, 8) = TextBox6.Text
If Cells(ActiveCell.Row, 9) <> "" Then Cells(ActiveCell.Row, 9) = TextBox7.Text
If Cells(ActiveCell.Row, 10) <> "" Then Cells(ActiveCell.Row, 10) = TextBox8.Text
Cells(ActiveCell.Row, 11) = TextBox9.Text
If TextBox10.Text = "" Then Cells(ActiveCell.Row, 12) = "" Else Cells(ActiveCell.Row, 12) = Val(TextBox10.Text)
Cells(ActiveCell.Row, 13) = UCase(TextBox11.Text)
Cells(ActiveCell.Row, 14) = ComboBox1.Text
Cells(ActiveCell.Row, 15) = ComboBox2.Text
Cells(ActiveCell.Row, 16) = ComboBox3.Text
If TextBox15.Text <> "" Then Cells(ActiveCell.Row, 17) = Val(TextBox15.Text) Else Cells(ActiveCell.Row, 17) = ""
If VerC = True Then VerN = False
If VerC = True Then Cells(ActiveCell.Row, 18) = "C" Else Cells(ActiveCell.Row, 18) = ""
If VerN = True Then VerC = False
If VerN = True Then Cells(ActiveCell.Row, 19) = "N" Else Cells(ActiveCell.Row, 19) = ""

If TextBox16.Text = "jj/mm/aaaa" Or TextBox16.Text = "" Then Cells(ActiveCell.Row, 20) = "" Else Cells(ActiveCell.Row, 20) = TextBox16.Text
Cells(ActiveCell.Row, 21) = TextBox17.Text

TextBox1.Enabled = True
TextBox2.Enabled = True
TextBox1.Text = ""                  'Initialide les champs
TextBox2.Text = ""
TextBox3.Text = ""
SexH = False
SexF = True
TextBox4.Text = "jj/mm/aaaa"
TextBox5.Text = ""
TextBox6.Text = ""
TextBox7.Text = ""
TextBox8.Text = ""
TextBox9.Text = ""
TextBox10.Text = ""
TextBox11.Text = ""
ComboBox1.Value = ""
ComboBox2.Value = ""
ComboBox3.Value = ""
TextBox15.Text = ""
VerC = True
VerN = False
TextBox16.Text = "jj/mm/aaaa"
TextBox17.Text = ""

TextBox1.SetFocus                               'Le curseur est placé dans le premien ch& du formulaire

End Sub

'******************************************************************
'Bouton MODIFICATION
'******************************************************************

Private Sub Modification_Click()
'Dim y As Integer

r = MsgBox(" Confirmez-vous la modification ? ", vbYesNo + vbInformation, "Gestion INSCRIPTIONS")
If r <> 6 Then Exit Sub
For i = 2 To Range("A:A").End(xlDown).Row
If TextBox1.Text = Cells(i, 1) And TextBox2.Text = Cells(i, 2) Then
TextBox1.Enabled = False
TextBox2.Enabled = False
If SexH = True Then SexF = False
If SexH = True Then Cells(i, 3) = "H" Else Cells(i, 3) = ""
If SexF = True Then SexH = False
If SexF = True Then Cells(i, 4) = "F" Else Cells(i, 4) = ""

Cells(i, 5) = TextBox3.Text
'For y = 2 To Range("a:a").End(xlDown).Row                               'Si le N° entré existe déjà.
'If Cells(y, 5).Text = TextBox3.Text Then MsgBox _
'"Ce N° d'adhérent est déjà attribué à " & Cells(y, 1).Value & " " & _
'Cells(y, 2).Value: TextBox3.Text = " ": TextBox3.SetFocus: Exit Sub      'il stope la procédure et affiche un message
'Next y

If TextBox4.Text = "jj/mm/aaaa" Or TextBox4.Text = "" Then Cells(i, 6) = "" Else Cells(i, 6) = TextBox4.Text
Cells(i, 7) = TextBox5.Text
If TextBox6 <> "" Then Cells(i, 8) = TextBox6.Text Else Cells(i, 8) = ""
If TextBox7 <> "" Then Cells(i, 9) = TextBox7.Text Else Cells(i, 9) = ""
If TextBox8 <> "" Then Cells(i, 10) = TextBox8.Text Else Cells(i, 10) = ""
Cells(i, 11) = TextBox9.Text
If TextBox10.Text = "" Then Cells(i, 12) = "" Else Cells(i, 12) = Val(TextBox10.Text)
Cells(i, 13) = UCase(TextBox11.Text)
If ComboBox1.Text = "" Then Cells(i, 14) = "" Else Cells(i, 14) = ComboBox1.Text
If ComboBox2.Text = "" Then Cells(i, 15) = "" Else Cells(i, 15) = ComboBox2.Text
If ComboBox3.Text = "" Then Cells(i, 16) = "" Else Cells(i, 16) = ComboBox3.Text
If TextBox15.Text = "" Then Cells(i, 17) = "" Else Cells(i, 17) = Val(TextBox15.Text) 'converti au passage les caractères en numérique
If VerC = True Then VerN = False
If VerC = True Then Cells(i, 18) = "C" Else Cells(i, 18) = ""
If VerN = True Then VerC = False
If VerN = True Then Cells(i, 19) = "N" Else Cells(i, 19) = ""

If TextBox16.Text = "jj/mm/aaaa" Or TextBox16.Text = "" Then Cells(i, 20) = "" Else Cells(i, 20) = CDate(TextBox16.Text)
Cells(i, 21) = TextBox17.Text
End If
Next i

TextBox1.Enabled = True
TextBox2.Enabled = True
TextBox1.Text = ""                  'Initialide les champs
TextBox2.Text = ""
TextBox3.Text = ""
SexH = False
SexF = True
TextBox4.Text = "jj/mm/aaaa"
TextBox5.Text = ""
TextBox6.Text = ""
TextBox7.Text = ""
TextBox8.Text = ""
TextBox9.Text = ""
TextBox10.Text = ""
TextBox11.Text = ""
ComboBox1.Value = ""
ComboBox2.Value = ""
ComboBox3.Value = ""
TextBox15.Text = ""
VerC = True
VerN = False
TextBox16.Text = "jj/mm/aaaa"
TextBox17.Text = ""

TextBox1.SetFocus        'Se place sur le premier champ du formulaire

End Sub

Private Sub CommandButton1_Click()

UserForm9.Hide
UserForm3.Show 1
End Sub

TitiPointCom67 · Answer

https://img-19.ccm2.net/DOpFxpZOSHbY71En9E-6cJ3Gd9E=/626c6073e11040ea95d066b0b07d65ea/ccm-ugc/Sans_nom-1.jpg

TitiPointCom67 · Answer

Image de l'userform avec listbox
https://img-19.ccm2.net/DOpFxpZOSHbY71En9E-6cJ3Gd9E=/626c6073e11040ea95d066b0b07d65ea/ccm-ugc/Sans_nom-2.jpg

TitiPointCom67 · Answer

https://img-19.ccm2.net/QuTkk28FjGFC4M_gOC0WO9xMz2Q=/90fe512ae6ff4a19841e4c6f6091ad8b/ccm-ugc/Sans_nom-2.jpg

f894009 · Answer

Re,

un exemple avec passage de donnees de UF1 vers UF1 et onglet Impression avec nom colonnes en ligne

 https://mon-partage.fr/f/5ltldHEN/

TitiPointCom67 · Answer

Re.
Comment fait-on pour vous transmettre un fichier ?

f894009 · Answer

Bonjour,

Pour transmettre un fichier,
Veillez a ce qu'il n'y ait PAS DE DONNEES CONFIDENTIELLES
il faut passer par un site de pièce jointe tel que cjoint.com

Allez sur ce site : https://www.cjoint.com/
Parametre le type de diffusion si par defaut ne convient pas
Clic sur parcourir,
Cherche ton fichier,
clic sur ouvrir,
Clic sur "Créer le lien cjoint",
Copier le lien,
Revenir ici le coller dans une réponse...

ou
'mon partage
https://mon-partage.fr/

TitiPointCom67 · Answer

Bonjour
voici le lien pour mon fichier.
https://www.cjoint.com/c/GIchWx6zLfw
J'ai vidé les tableaux car ils contenaient des données confidentielles, ce qui fait que le programme ne tourne plus exactement comme il le devrait.

TitiPointCom67 · Answer

Je précise également que vu mes connaissances, je n'ai fait qu'adapter à mes besoins des morceaux de code trouvés par-ci par-là. Il est fort probable qu'il y ait moyen de faire beaucoup mieux avec moins de code mais du moment que ça marche, moi ça me va.
Encore merci pour votre aide.

f894009 · Answer

Re
Ok, je récupéré le fichier

f894009 · Answer

Bonjour,
Je vois cela dans la journee, petit probleme logistique

TitiPointCom67 · Answer

Je précise:
Dans le fichier que vous m'avez transmis, ça fonctionne,
Mais si je prend le code et que je le colle dans mon fichier d'origine avec toutes les données, ca ne fonctionne plus. Pourtant, je n'ai rien changé de plus que ce que ce qui suit:

Votre code d'origine :

'Private Sub ListBox1_Click()
'    Erase TInfos
'    For i = 0 To 20                                                 
'        TInfos(i) = ListBox1.List(Me.ListBox1.ListIndex, i)    
'    Next i
'    Flg_TI = True
'    Unload Me
'    UserForm3.Show
'End Sub


déplacé sur le bouton :

Private Sub CommandButton1_Click()
  Erase TInfos
    For i = 0 To 20
        TInfos(i) = ListBox1.List(Me.ListBox1.ListIndex, i)
    Next i
    Flg_TI = True
    Unload Me
    UserForm3.Show
End Sub


J'ai également rajouté dans le Module1:

Public Flg_TI As Boolean


Avez-vous modifié autre chose que je n'aurais pas vu et qui expliquerait cela ?

TitiPointCom67 · Answer

Re.
Effectivement, je n'avais pas vu ces changements.
Maintenant ça marche impeccablement.
Merci beaucoup pour votre patience et votre aide.

TitiPointCom67 · Answer

Bonjour
comment enlever les pointillés qui entourent une sélection de cellules une fois que l'on a plus besoin de cette sélection (en vba)
C'est juste une question d’esthétique, cela n'interfère en rien dans le programme.
Merci

TitiPointCom67 · Answer

Re
Non, ça ne fonctionne pas.

Extraction de listbox.

17 réponses

Discussions similaires

Newsletters