Résolu VBA - Transfert d'une listebox à une autre avec mise à jour des tableaux sur la feuille

piga25

XLDnaute Barbatruc
Bonjour,
Poursuivant l'élaboration de mon fichier, je me retrouve avec un nouveau problème.
J'ai bien trouvé un très gros début de solution sur le site de M Boisgontier Jacques; mais après de nombreux essais je n'y arrive pas.
J'aimerai que lorsque l'on active un optionButton que cela indique à la listebox de prendre une certaine base et ainsi de suite.
Le résultat attendu est mieux expliqué sur le fichier joint.
En vous remerciant
 

Fichiers joints

Robert

XLDnaute Barbatruc
Bonjour Piga, bonjour le forum,

En pièce jointe ton fichier modifié avec un module classe qui permet de n'utiliser qu'un seul code au clic d'un des boutons d'option. Regarde si ça te convient...
 

Fichiers joints

piga25

XLDnaute Barbatruc
Bonjour ROBERT, le forum

Merci.
J'ai compris le fonctionnement, par contre il faut que je regarde bien les changements de liste de manière à bien faire la boucle dans les différents emplacements.
J'ai modifié le code pour que la liste de destination prenne en compte ceux qui y sont déjà.

Il faut que ces listes se classent également soit par ordre de n° ou soit par ordre alphabétique (je pense qu'il me faut 2 optionbutton dans une frame pour pouvoir choisir)

VB:
Public WithEvents OB As MSForms.OptionButton

Private Sub OB_Click()
Dim F As Worksheet

Set F = Worksheets("Tâches")
If OB = True Then
    Select Case OB.Caption
        Case "Inscription"
            F_Transfert.Label1.Caption = "Liste Pref."
            F_Transfert.Label3.Caption = "Incription"
            F_Transfert.Source.List = F.Range("A2:B" & F.[A65000].End(xlUp).Row).Value
            F_Transfert.Dest.List = F.Range("E2:F" & F.[E65000].End(xlUp).Row).Value
        Case "Départ PC"
            F_Transfert.Label1.Caption = "Inscription"
            F_Transfert.Label3.Caption = "Départ PC"
            F_Transfert.Source.List = F.Range("E2:F" & F.[E65000].End(xlUp).Row).Value
            F_Transfert.Dest.List = F.Range("H2:I" & F.[H65000].End(xlUp).Row).Value
        Case "Entre cavité"
            F_Transfert.Label1.Caption = "Départ PC"
            F_Transfert.Label3.Caption = "Entre cavité"
            F_Transfert.Source.List = F.Range("H2:I" & F.[H65000].End(xlUp).Row).Value
            F_Transfert.Dest.List = F.Range("K2:L" & F.[K65000].End(xlUp).Row).Value
        Case "Sort cavité"
            F_Transfert.Label1.Caption = "Entre cavité"
            F_Transfert.Label3.Caption = "Sort Cavité"
            F_Transfert.Source.List = F.Range("K2:L" & F.[K65000].End(xlUp).Row).Value
            F_Transfert.Dest.List = F.Range("N2:O" & F.[N65000].End(xlUp).Row).Value
        Case "Retour PC"
            F_Transfert.Label1.Caption = "Sort cavité"
            F_Transfert.Label3.Caption = "Retour PC"
            F_Transfert.Source.List = F.Range("N2:O" & F.[N65000].End(xlUp).Row).Value
            F_Transfert.Dest.List = F.Range("Q2:R" & F.[Q65000].End(xlUp).Row).Value
        Case "Quitte le site"
            F_Transfert.Label1.Caption = "Retour PC"
            F_Transfert.Label3.Caption = "Liste Pref."
            F_Transfert.Source.List = F.Range("Q2:R" & F.[Q65000].End(xlUp).Row).Value
            F_Transfert.Dest.List = F.Range("H2:I" & F.[H65000].End(xlUp).Row).Value

    End Select
End If
End Sub
 

piga25

XLDnaute Barbatruc
Bonjour Robert, le forum
J'ai bien avancé mais j'ai un petit problème à résoudre.
Lorsque je clique sur le bouton Retour sur la liste préfectorale il faudrait que les optionButton se mettent tous en position False
Merci
 

Fichiers joints

piga25

XLDnaute Barbatruc
RE
C'est bon j'ai trouvé
VB:
Private TOB(1 To 6) As New OptButons 'déclare le tableau TOB (Tableau des OptionButtons)
Dim F As Worksheet, F2 As Worksheet, OB As OptButons

Private Sub CommandButton2_Click()
UserForm_Initialize
For I = 1 To 6
    Set TOB(I).OB = Me.Controls("Optionbutton" & I)
    TOB(I).OB = False
Next I
End Sub
Bon maintenant je m'attache à masquer une partie de l'userform et cela tant qu'un optionButton ne soit activé.
 

piga25

XLDnaute Barbatruc
RE
j'arrive bien à masquer ce que je souhaite en cliquant sur le bouton CommandButton2, mais par contre je n'arrive pas à les rendre visibles en cliquant sur un des 6 optionbutton

VB:
Private TOB(1 To 6) As New OptButons 'déclare le tableau TOB (Tableau des OptionButtons)
Dim F As Worksheet, F2 As Worksheet, OB As OptButons

Private Sub CommandButton2_Click()
UserForm_Initialize
For I = 1 To 6
    Set TOB(I).OB = Me.Controls("Optionbutton" & I)
    TOB(I).OB = False
Next I
    Source.Visible = False
    b_prend.Visible = False
    B_enlève.Visible = False
    B_transfert.Visible = False
    CommandButton2.Visible = False
End Sub

Private Sub OB_Click()
UserForm_Initialize
Dim I As Byte
For I = 1 To 6
    Set TOB(I).OB = Me.Controls("Optionbutton" & I)
    TOB(I).OB = True
Next I
    Source.Visible = True
    b_prend.Visible = True
    B_enlève.Visible = True
    B_transfert.Visible = True
    CommandButton2.Visible = True
End Sub
 

piga25

XLDnaute Barbatruc
Bonjour le forum

Nouveau problème.
Comment alimenter la ListBox : Dest , à partir des TextBox3, TextBox1 et TextBox2 de manière à avoir dans la ListeBox DEST :
en colonne 1 = N° + valeur de la textBox3
en colonne 2 = valeur de la textBox1 & " " & valeur de la textBox2.
VB:
Private Sub CommandButton1_Click()
If TextBox3 = "" Then
MsgBox "Vous n'avez pas renseigné le n° d'inscription figurant sur le listing !", vbOKOnly + vbExclamation, "Piga25"
       Me.Dest.AddItem ("N° " & TextBox3.Value)
       pos = Me.Dest.ListCount - 1
       Me.Dest.List(pos, 1) = TextBox1.Value & " " & TextBox2.Value
End If
TextBox1 = ""
TextBox2 = ""
TextBox3 = ""
End Sub
Merci
 

BOISGONTIER

XLDnaute Barbatruc
Bonour,

Ce que j'ai compris.

VB:
Dim f
Private Sub UserForm_Initialize()
  Me.Source.MultiSelect = fmMultiSelectMulti
  Set f = Sheets("feuil1")
  Me.ListBox1.List = Array("Inscription", "Départ PC", "Entrée cavité", "Sort cavité", "retour pc")
  Me.ListBox1.ListIndex = 0
  Me.Destination.Caption = Me.ListBox1.List(0)
  p = Me.ListBox1.ListIndex
  n = f.[A65000].Offset(, p * 3).End(xlUp).Row
  If n > 1 Then Me.Source.List = f.Range("A2:B" & n).Offset(, p * 3).Value Else Me.Source.Clear
  n = f.[D65000].Offset(, p * 3).End(xlUp).Row
  If n > 1 Then Me.Dest.List = f.Range("D2:E" & n).Offset(, p * 3).Value Else Me.Dest.Clear
End Sub

Private Sub ListBox1_Click()
  Me.Destination.Caption = Me.ListBox1
  p = Me.ListBox1.ListIndex
  n = f.[A65000].Offset(, p * 3).End(xlUp).Row
  If n > 1 Then Me.Source.List = f.Range("A2:B" & n).Offset(, p * 3).Value Else Me.Source.Clear
  n = f.[D65000].Offset(, p * 3).End(xlUp).Row
  If n > 1 Then Me.Dest.List = f.Range("D2:E" & n).Offset(, p * 3).Value Else Me.Dest.Clear
End Sub

Private Sub B_enlève_Click()
  If Me.Dest.ListCount > 0 And Me.Dest.ListIndex <> -1 Then
    Me.Source.AddItem Me.Dest
    pos = Me.Source.ListCount - 1
    Me.Source.List(pos, 1) = Me.Dest.Column(1)
    Me.Dest.RemoveItem Me.Dest.ListIndex
  End If
End Sub

Private Sub b_prend_Click()
  If Me.Source.ListIndex <> -1 And Me.Source.ListCount > 0 Then
    For i = 0 To Me.Source.ListCount - 1
    If Me.Source.Selected(i) = True Then
       Me.Dest.AddItem Me.Source.List(i)
       pos = Me.Dest.ListCount - 1
       Me.Dest.List(pos, 1) = Me.Source.List(i, 1)
    End If
   Next i
   For i = Me.Source.ListCount - 1 To 0 Step -1
    If Me.Source.Selected(i) = True Then Me.Source.RemoveItem i
   Next i
  End If
End Sub

Private Sub B_transfert_Click()
  p = Me.ListBox1.ListIndex
  n = Me.Dest.ListCount
  f.[D2].Offset(, p * 3).Resize(25, 2).ClearContents
  If n > 0 Then f.[D2].Offset(, p * 3).Resize(n, 2) = Me.Dest.List
  n = Me.Source.ListCount
  f.[A2].Offset(, p * 3).Resize(25, 2).ClearContents
  If n > 0 Then f.[A2].Offset(, p * 3).Resize(n, 2) = Me.Source.List
End Sub

Boisgontier
 

Fichiers joints

Dernière édition:

piga25

XLDnaute Barbatruc
Bonjour Boisgontier, le Forum

Merci pour cet exemple. A première vue cela est plus simple de ce que j'avais commencé à faire.
Je regarde cela en détail et je vous tiendrai informé.
Le plus dur pour moi, cela va être de bien tout comprendre.
Merci
 

piga25

XLDnaute Barbatruc
Bonjour Boigonstier, le Forum

Très bien comme concept, simple et précis. Vous avez parfaitement compris le sens de ce que je souhaitais réaliser.
Néanmoins, oui je sais on en veux toujours un peu plus. J'aimerai que l'on ne puisse pas ajouter une personne hormis le cas INSCRIPTION (inscription de coché dans listbox1). Dans ce cas, il faudrait une listebox sous la textbox2 (s'affiche pour choisir le nom et se cache une fois le choix fait) que ce choix s'affiche en textbox2, comme cela on lui affecte un n° autre que celui qu'il a dans la liste Préf. (la routine repart normalement avec la touche +)

J'ai ajouté le cas "quitte le site". Là il faudrait charger en Source (tableau des inscrits E:F ) et en Dest (tableau "liste préf" A:B)
Je suis arrivé à ajouter une autre listbox que j'ai nommé MAIN. Elle prend en compte que les modifications effectuées. Pour l'instant cela s'affiche bien dans cette listbox, mais pas sur la feuille (emplacement souhaité: colonnes V et W - c'est un emplacement fixe). Je ne sais pas si cela soit vraiment nécessaire, c'est peut jouable uniquement avec la listbox MAIN. Autrement, il faudrait que ce tableau s'efface lorsque l'on change de position (changement dans listbox1).

La finalité est de reprendre de ce qui figure dans la listebox MAIN pour l'intégrer dans une textbox dans un autre Userform , par exemple :
Arrive sur le site de : Nom1 Prénom1
Départ en mission de : Nom2 Prénom2
Entre dans la cavité : Nom5 Prénom5
Sortie de la cavité de : Nom6 Prénom6
Fin de mission de : Nom9 Prénom9
Quitte le site de : Nom3 Prénom3

Que cela alimente cette textbox à la validation (click sur "transfert sur feuille") avec fermeture de l'userform (Unload Me - UserForm2.Show ' en prévision pour l'intégration dans fichier complet)

Ma tentative d'ajout de code est annoté dans chaque sub() - J'espère ne pas avoir matraqué vos codes.
En vous remerciant
 

Fichiers joints

piga25

XLDnaute Barbatruc
Re,
Ce n'est pas exactement comme cela.
1/ en ce qui concerne la listebox historique, celle-ci doit se vider lorsque l'on clique sur transfert feuille. C'est ce contenu que je désire récupérer pour insérer dans un autre userform. Le but est de pouvoir créer une phrase type suivi des Nom Prénom (comme mentionné dans mon précédent post).
2/ en ce qui concerne le choix : Inscription, il faudrait que les données passent obligatoirement par la frame Ajout. Ce qui permet d'attribuer un n° à la personne. Là, il y a jute besoin des données de la colonne 2 (NOM Prénom).
3/ Il faudrait également que je puisse enlever des personnes pour les remettre dans la liste préf. Cas : Quitte le site

Déjà un grand merci pour ce que vous avez fait.

Je vous mets en exemple le fichier que j'avais déjà réalisé au préalable, pour vous montrer la démarche que je souhaite avoir. Dans celui-là je bloques pour mettre à jour les tableaux sur la feuille. Malheureusement il est moins concis que le votre.
 

Fichiers joints

piga25

XLDnaute Barbatruc
Re
En effet c'est pas mal, de cette façon j'ai un historique de tous les mouvements des personnels que je peux avoir à part.

Je regarde cela de plus près pour bien assimiler les codes.

Merci
 

piga25

XLDnaute Barbatruc
Bonjour Robert, Boisgontier, le forum

J'ai bien avancé et cela fonctionne pratiquement bien, néanmoins J'ai une erreur dans ce code :
VB:
Private Sub B_enlève_Click()
    If Me.Dest.ListIndex <> -1 And Me.Dest.ListCount > 0 Then
    For i = 0 To Me.Dest.ListCount - 1
    If Me.Dest.Selected(i) = True Then
        Me.Source.AddItem Me.Dest.List(i)
        pos = Me.Source.ListCount - 1
        Me.Source.List(pos, 1) = Me.Dest.List(i, 1)
      '---histo
        Me.Historique.AddItem Me.Dest.List(i)
        posh = Me.Historique.ListCount - 1
        Me.Historique.List(posh, 1) = Me.Dest.List(i, 1)
        Me.Historique.List(posh, 2) = Me.Destination.Caption
        Me.Historique.List(posh, 3) = Format(Now, "hh:mm le dd/mm/yyyy")
        '---Main courante
        Me.Main.AddItem Me.Source.List(i) ' bug lorsque l'on clique une seconde fois dans le cas Sort cavité
        posh = Me.Main.ListCount - 1
        Me.Main.List(posh, 0) = Me.Dest.List(i, 1)
        Me.Main.List(posh, 1) = Me.Destination.Caption
        Me.Main.List(posh, 2) = Format(Now, "hh:mm le dd/mm/yyyy")
    End If
        Next i
    For i = Me.Dest.ListCount - 1 To 0 Step -1
      If Me.Dest.Selected(i) = True Then Me.Dest.RemoveItem i
    Next i
  B_transfert_Click
  B_Histo_Click
  End If
End Sub
1027286

Et puis ici, je n'arrive pas a transférer toutes les lignes de la listbox MAIN dans une textbox située dans un autre userform.
J'ai essayé avec : userform1.textbox1.value = Me.main.list mais sans résultat !!!!!
 

Fichiers joints

Dernière édition:

piga25

XLDnaute Barbatruc
Bonsoir le Forum
Après recherches, je pense avoir trouvé. En plus il n'y avait pas une erreur mais deux.
VB:
Private Sub B_enlève_Click()
    If Me.Dest.ListIndex <> -1 And Me.Dest.ListCount > 0 Then
    For i = 0 To Me.Dest.ListCount - 1
    If Me.Dest.Selected(i) = True Then
        Me.Source.AddItem Me.Dest.List(i)
        pos = Me.Source.ListCount - 1
        Me.Source.List(pos, 1) = Me.Dest.List(i, 1)
      '---histo
        Me.Historique.AddItem Me.Dest.List(i)
        posh = Me.Historique.ListCount - 1
        Me.Historique.List(posh, 1) = Me.Dest.List(i, 1)
        Me.Historique.List(posh, 2) = Me.Destination.Caption
        Me.Historique.List(posh, 3) = Format(Now, "hh:mm le dd/mm/yyyy")
        '---Main courante
        Me.Main.AddItem Me.Dest.List(i) ' bug lorsque l'on clique une seconde fois dans le cas Retour PC
        posh = Me.Main.ListCount - 1
        Me.Main.List(posh, 0) = Me.Dest.List(i, 1)
        Me.Main.List(posh, 1) = Me.Destination.Caption
        Me.Main.List(posh, 2) = Format(Now, "hh:mm le dd/mm/yyyy")
    End If
        Next i
    'For j = Me.Dest.ListCount - 1 To 0 Step -1
      'If Me.Dest.Selected(j) = True Then Me.Dest.RemoveItem (j)
    'Next j
    If Me.Dest.ListCount > 0 And Me.Dest.ListIndex <> -1 Then Me.Dest.RemoveItem Me.Dest.ListIndex
  End If
  B_transfert_Click
  B_Histo_Click
  B_Main_Click
La première venait d'une erreur de listbox :
'---Main courante
Me.Main.AddItem Me.Source.List(i) -- Ici pas la bonne listbox.
Me.Main.AddItem Me.Dest.List(i) - Ici correct.
La seconde c'est lorsque l'on fait un décrément dans la listbox.
J'ai remplacé :
'For j = Me.Dest.ListCount - 1 To 0 Step -1
'If Me.Dest.Selected(j) = True Then Me.Dest.RemoveItem (j)
'Next j
par : If Me.Dest.ListCount > 0 And Me.Dest.ListIndex <> -1 Then Me.Dest.RemoveItem Me.Dest.ListIndex

Il me reste juste ceci à faire, transférer toutes les lignes de la listbox MAIN dans une textbox située dans un autre userform.
 

piga25

XLDnaute Barbatruc
Bonjour le forum

J'ai trouvé pour mon dernier problème, il suffisait de concaténer dans une seule cellule et de copier cette cellule dans le textbox multiligne.
Je met le fichier complet pour ceux que cela pourrait intéresser.

VB:
Sub Concatene()
Dim Cel As Range, Co As Range
Dim Lg, i As Long
Application.ScreenUpdating = False
k = [S1]
    If k > 0 Then
        For i = 2 To k + 1
            Range("O" & i).Select
            ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[3],"" de "",RC[2],"" à "",RC[4])"
        Next i
    End If
Lg = [O65536].End(xlUp).Row
    With Range("N1")
      .ClearContents
           For Each Cel In Range("O2:O" & Lg)
              If Cel <> "" Then
                .Value = .Value & Cel.Value & Chr(10)
              Else: Exit For
              End If
           Next Cel
    End With
End Sub
 

Fichiers joints

Discussions similaires


Haut Bas