[XL-2016] Probleme VBA fichier

1 pièce(s) jointe(s)

Probleme VBA fichier

Bonjour je débute en vba, j'ai repris du code trouvé sur le forum afin de l'adapter à ma petite base de donnée.
J'ai deux petit problème après adaptation,
1. lorsque je sélectionne des noms dans la colonne B ils ne se mettent plus un en dessous de l'autre quand il arrivent en fin de colonne mais un derrière l'autre.
2. Lorque je veux insérer une ligne j'ai un bug.
Pourriez-vous m'aider.
Merci

Bonjour

Il serait souhaitable de donner le code, car les pièces jointes ne sont pas ouvertes par tous :

https://www.developpez.net/forums/d8...s-discussions/

Merci

Philippe

code

Voici le code

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
Option Explicit
 
Dim interne As Boolean
Sub LbxPrenom_Change()
    Dim ch As String, i As Long, sep As String
    If Not interne Then
        ch = ""
        sep = [separateur]
        For i = 0 To LbxPrenom.ListCount - 1
            If LbxPrenom.Selected(i) = True Then ch = ch & sep & LbxPrenom.List(i)
        Next i
        ch = Mid(ch, Len(sep) + 1)
        ActiveCell = ch
    End If
End Sub
 
Sub LbxPrenom_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
' un clic droit désélectionne ou sélectionne l'ensemble de la liste
    Dim i As Long, cpt As Long, state As Boolean
    Dim LbxPrenom
    If Button = xlSecondaryButton Then  ' si clic-droit
        ' nb sélections
        For i = 0 To LbxPrenom.ListCount - 1
            If LbxPrenom.Selected(i) Then cpt = cpt + 1
        Next i
        ' si aucune sélection sélectionner tout
        ' sinon désélectionner tout
        If cpt = 0 Then state = True Else state = False
        interne = True    ' palliatif, EnableEvents ne marche pas
        For i = 0 To LbxPrenom.ListCount - 1
            LbxPrenom.Selected(i) = state
        Next i
        interne = False
    End If
    LbxPrenom_Change
End Sub
Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim ch As String, ch2 As String, pos As Long, i As Long
    Dim plage, nomListe, numListe As Long, topIndex As Boolean
    'Dim LbxPrenom
    ' plages avec sélection multiple sur cette feuille
    plage = Array("B3:B500")
    ' nom des liste dans la feuille liste (en liaison avec les plages définies au-dessus)
    nomListe = Array("Prenom")
    ' plage concernée ?
    For numListe = 0 To UBound(plage)
        If Not Intersect(Target, Range(plage(numListe))) Is Nothing Then Exit For
    Next numListe
 
    If numListe <= UBound(plage) Then ' si plage de liste existant
        ' initialiser listbox
        LbxPrenom.ListFillRange = "Liste!" & Worksheets("Liste").Range(nomListe(numListe)).Address
        LbxPrenom.Top = Target.Offset(1, 0).Top
        LbxPrenom.Left = Target.Offset(0, 1).Left
 
        interne = True    ' palliatif, EnableEvents ne marche pas
        ch = ActiveCell
        ch2 = [separateur] & ch & [separateur]
        topIndex = False
        ' sélectionner selon contenu cellule
        For i = 0 To LbxPrenom.ListCount - 1
            If InStr(ch2, [separateur] & LbxPrenom.List(i) & [separateur]) > 0 Then
                ' l'item a été trouvé dans la cellule
                LbxPrenom.Selected(i) = True
                If Not topIndex Then
                    LbxPrenom.topIndex = i    ' le 1er sélectionné doit être visible dans la textbox
                    topIndex = True
                End If
            End If
        Next i
        interne = False
        ' afficher textbox
        LbxPrenom.Visible = True
    Else
        ' ne plus afficher la textbox
        LbxPrenom.Visible = False
    End If
End Sub
 
Sub reinit()
    Application.EnableEvents = True
End Sub

merci