Sujet Précédent Sujet Suivant

Extraction de listbox.

Résolu/Fermé
TitiPointCom67 Messages postés 38 Date d'inscription vendredi 25 août 2017 Statut Membre Dernière intervention 12 septembre 2017 - 30 août 2017 à 19:34
TitiPointCom67 Messages postés 38 Date d'inscription vendredi 25 août 2017 Statut Membre Dernière intervention 12 septembre 2017 - 7 sept. 2017 à 12:34
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.

17 réponses

Réponse 1 / 17
fabien25000 Messages postés 673 Date d'inscription mercredi 5 octobre 2016 Statut Membre Dernière intervention 28 juillet 2022 58
30 août 2017 à 19:58
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 ;)
0
Réponse 2 / 17
TitiPointCom67 Messages postés 38 Date d'inscription vendredi 25 août 2017 Statut Membre Dernière intervention 12 septembre 2017
30 août 2017 à 20:15
Qu'entendez-vous par fichier exemple ?
Dois-je joindre le code déjà existant ?
0
fabien25000 Messages postés 673 Date d'inscription mercredi 5 octobre 2016 Statut Membre Dernière intervention 28 juillet 2022 58
30 août 2017 à 20:26
surtout un fichier qui ne dévoile rien qui puisse etre confidentiel oui
0
Réponse 3 / 17
TitiPointCom67 Messages postés 38 Date d'inscription vendredi 25 août 2017 Statut Membre Dernière intervention 12 septembre 2017
30 août 2017 à 20:39
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


<gras>Ceci est le code de l'userform contenant les champs</gras>

<code basic>
'*********************************************************************
' 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
0
Réponse 4 / 17
TitiPointCom67 Messages postés 38 Date d'inscription vendredi 25 août 2017 Statut Membre Dernière intervention 12 septembre 2017
30 août 2017 à 20:46
https://img-19.ccm2.net/DOpFxpZOSHbY71En9E-6cJ3Gd9E=/626c6073e11040ea95d066b0b07d65ea/ccm-ugc/Sans_nom-1.jpg
0

Vous n’avez pas trouvé la réponse que vous recherchez ?

Posez votre question
Réponse 5 / 17
TitiPointCom67 Messages postés 38 Date d'inscription vendredi 25 août 2017 Statut Membre Dernière intervention 12 septembre 2017
Modifié le 30 août 2017 à 20:54
Image de l'userform avec listbox
https://img-19.ccm2.net/DOpFxpZOSHbY71En9E-6cJ3Gd9E=/626c6073e11040ea95d066b0b07d65ea/ccm-ugc/Sans_nom-2.jpg
0
f894009 Messages postés 17185 Date d'inscription dimanche 25 novembre 2007 Statut Membre Dernière intervention 15 avril 2024 1 701
Modifié le 31 août 2017 à 07:46
Bonjour,

Pas d'image!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
et
l'UF Adherents est Userform3 ???
0
TitiPointCom67 Messages postés 38 Date d'inscription vendredi 25 août 2017 Statut Membre Dernière intervention 12 septembre 2017
31 août 2017 à 10:44
Oui, je l'avais appelée comme cela pour simplifier mon exposé mais son nom est effectivement Userform3 et l'Userform contenant la listbox est nommé Userform9.
0
Réponse 6 / 17
TitiPointCom67 Messages postés 38 Date d'inscription vendredi 25 août 2017 Statut Membre Dernière intervention 12 septembre 2017
31 août 2017 à 10:42
https://img-19.ccm2.net/QuTkk28FjGFC4M_gOC0WO9xMz2Q=/90fe512ae6ff4a19841e4c6f6091ad8b/ccm-ugc/Sans_nom-2.jpg
0
Réponse 7 / 17
f894009 Messages postés 17185 Date d'inscription dimanche 25 novembre 2007 Statut Membre Dernière intervention 15 avril 2024 1 701
31 août 2017 à 14:40
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/
0
TitiPointCom67 Messages postés 38 Date d'inscription vendredi 25 août 2017 Statut Membre Dernière intervention 12 septembre 2017
Modifié le 31 août 2017 à 15:08
Re aussi
Merci pour cet exemple, mais j'aurais voulu que la colonne A de l'impression corresponde en fait à la ligne 1 du tableau en jaune, de manière à ce que l'on sache à quoi correspond chaque élément de la colonne B.
dans le style
1 30
2 FAUX
3 VRAI
4 33
5 34
0
f894009 Messages postés 17185 Date d'inscription dimanche 25 novembre 2007 Statut Membre Dernière intervention 15 avril 2024 1 701 > TitiPointCom67 Messages postés 38 Date d'inscription vendredi 25 août 2017 Statut Membre Dernière intervention 12 septembre 2017
31 août 2017 à 17:40
Re,

Ben, le titre des colonnes ne changent pas, je suppose, ecrivez les en colonne A et ecrire par le code les infos en colonne B
0
TitiPointCom67 Messages postés 38 Date d'inscription vendredi 25 août 2017 Statut Membre Dernière intervention 12 septembre 2017 > f894009 Messages postés 17185 Date d'inscription dimanche 25 novembre 2007 Statut Membre Dernière intervention 15 avril 2024
31 août 2017 à 17:43
Effectivement, c'est tout bête mais il fallait y penser. Merci beaucoup
0
f894009 Messages postés 17185 Date d'inscription dimanche 25 novembre 2007 Statut Membre Dernière intervention 15 avril 2024 1 701 > TitiPointCom67 Messages postés 38 Date d'inscription vendredi 25 août 2017 Statut Membre Dernière intervention 12 septembre 2017
31 août 2017 à 18:32
Re
Juste une rectif pour le resize, c'est 21,1
0
TitiPointCom67 Messages postés 38 Date d'inscription vendredi 25 août 2017 Statut Membre Dernière intervention 12 septembre 2017
31 août 2017 à 18:34
Oui, j'avais rectifié, Merci encore
0
Réponse 8 / 17
TitiPointCom67 Messages postés 38 Date d'inscription vendredi 25 août 2017 Statut Membre Dernière intervention 12 septembre 2017
1 sept. 2017 à 23:00
Re.
Comment fait-on pour vous transmettre un fichier ?
0
Réponse 9 / 17
f894009 Messages postés 17185 Date d'inscription dimanche 25 novembre 2007 Statut Membre Dernière intervention 15 avril 2024 1 701
2 sept. 2017 à 07:20
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/
0
Réponse 10 / 17
TitiPointCom67 Messages postés 38 Date d'inscription vendredi 25 août 2017 Statut Membre Dernière intervention 12 septembre 2017
2 sept. 2017 à 09:52
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.
0
Réponse 11 / 17
TitiPointCom67 Messages postés 38 Date d'inscription vendredi 25 août 2017 Statut Membre Dernière intervention 12 septembre 2017
2 sept. 2017 à 10:34
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.
0
Réponse 12 / 17
f894009 Messages postés 17185 Date d'inscription dimanche 25 novembre 2007 Statut Membre Dernière intervention 15 avril 2024 1 701
2 sept. 2017 à 10:49
Re
Ok, je récupéré le fichier
0
Réponse 13 / 17
f894009 Messages postés 17185 Date d'inscription dimanche 25 novembre 2007 Statut Membre Dernière intervention 15 avril 2024 1 701
4 sept. 2017 à 07:57
Bonjour,
Je vois cela dans la journee, petit probleme logistique
0
TitiPointCom67 Messages postés 38 Date d'inscription vendredi 25 août 2017 Statut Membre Dernière intervention 12 septembre 2017
4 sept. 2017 à 09:00
Bonjour,
Faites comme chez vous, prenez le temps qu'il vous faudra. D'une part il n'y a pas une grande urgence et d'autre part, je serais également pas mal occupé aujourd'hui.
C'est fou la vie d'un retraité, on est toujours débordé ...
0
f894009 Messages postés 17185 Date d'inscription dimanche 25 novembre 2007 Statut Membre Dernière intervention 15 avril 2024 1 701 > TitiPointCom67 Messages postés 38 Date d'inscription vendredi 25 août 2017 Statut Membre Dernière intervention 12 septembre 2017
4 sept. 2017 à 12:34
Re,

fichier modifie, mais a vous de voir pour le bouton impression car si click sur une ligne listbox retour sur UF3. Donc voir si doubleclick listbox au lieu de click

http://www.cjoint.com/c/GIekIpPhPEf
0
TitiPointCom67 Messages postés 38 Date d'inscription vendredi 25 août 2017 Statut Membre Dernière intervention 12 septembre 2017
4 sept. 2017 à 13:08
Re.
Merci beaucoup,
Je télécharge maintenant mais je ne pourrais voir ce que ça donne que ce soir.
Je vous tiens au courant dès demain matin.
0
f894009 Messages postés 17185 Date d'inscription dimanche 25 novembre 2007 Statut Membre Dernière intervention 15 avril 2024 1 701 > TitiPointCom67 Messages postés 38 Date d'inscription vendredi 25 août 2017 Statut Membre Dernière intervention 12 septembre 2017
4 sept. 2017 à 13:31
Re,
Ca roule
0
TitiPointCom67 Messages postés 38 Date d'inscription vendredi 25 août 2017 Statut Membre Dernière intervention 12 septembre 2017
4 sept. 2017 à 20:59
Re.
Après plusieurs essais, ça ne fonctionne pas. L'UF3 s'ouvre systématiquement sur la première ligne du tableau et non sur celle sélectionnée dans la ListBox.
Par contre, au lieu de mettre le code au niveau du clik sur la ListBox, je l'ai mis sur le bouton "RETOUR FORMULAIRE" comme cela plus de problème avec l'impression et comme le but est entre autre de retourner sur le formulaire, ça va très bien.
Reste plus qu'à trouver pourquoi ce n'est pas la bonne ligne qui s'affiche au retour dans l'UF3
0
Réponse 14 / 17
TitiPointCom67 Messages postés 38 Date d'inscription vendredi 25 août 2017 Statut Membre Dernière intervention 12 septembre 2017
5 sept. 2017 à 12:20
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 ?
0
f894009 Messages postés 17185 Date d'inscription dimanche 25 novembre 2007 Statut Membre Dernière intervention 15 avril 2024 1 701
5 sept. 2017 à 13:31
Re,

fichier qui marche: http://www.cjoint.com/c/GIflAOeqXpf

Il y a aussi des modifs dans Userform3 qui figurent deja dans le fichier precedent, au cas ou vous recopiez les modifs, notamment 
Private Sub UserForm_Initialize()

et 
'retour de UF9
Private Sub UserForm_Activate()
0
Réponse 15 / 17
TitiPointCom67 Messages postés 38 Date d'inscription vendredi 25 août 2017 Statut Membre Dernière intervention 12 septembre 2017
5 sept. 2017 à 14:36
Re.
Effectivement, je n'avais pas vu ces changements.
Maintenant ça marche impeccablement.
Merci beaucoup pour votre patience et votre aide.
0
f894009 Messages postés 17185 Date d'inscription dimanche 25 novembre 2007 Statut Membre Dernière intervention 15 avril 2024 1 701
5 sept. 2017 à 17:57
Re,
Si vous avez besoin d'autre chose, pas de probleme
0
Réponse 16 / 17
TitiPointCom67 Messages postés 38 Date d'inscription vendredi 25 août 2017 Statut Membre Dernière intervention 12 septembre 2017
7 sept. 2017 à 11:17
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
0
pijaku Messages postés 12263 Date d'inscription jeudi 15 mai 2008 Statut Modérateur Dernière intervention 4 janvier 2024 2 743
7 sept. 2017 à 12:31
Bonjour,
Peut-être : 
Application.CutCopyMode = False
0
Réponse 17 / 17
TitiPointCom67 Messages postés 38 Date d'inscription vendredi 25 août 2017 Statut Membre Dernière intervention 12 septembre 2017
7 sept. 2017 à 12:34
Re
Non, ça ne fonctionne pas.
0

Discussions similaires

Winrar - Problème extraction volume précédent
Yoruic -
NeiluJ -

19 réponses
Probleme d'extraction de fichier sous android
Elg -
dragiMax99 -

3 réponses
Le dossier compressé n'est pas valide
Cunegonde36 -
Malekal_morte- -

1 réponse
extraction erreur d'écriture du fichier C:/User/user/appdata/local
winnie23 -
billmaxime -

33 réponses
Erreur des dossiers compressés
Lutty-Chan -
gbinforme -

1 réponse