Délimité une zone de l'enregistrement de données dans ListBox

[Chri8Ed]

Bonjour à tous
Je souhaiterais dans ma ListBox délimiter la zone de récupération aux seules colonnes J à V
Voir dans mon fichier le commentaire Exemple qui apparait alors qu'il ne le devrait pas
Après pas mal de tentative, je ne trouve pas la solution
Si quelqu'un peut m'aider
Merci d'avance

 

[vgendron]

Hello

essai ce code

Sub alimCommentaires()
Dim shListe As Worksheet
Dim Cmnt As Comment
Dim nom$, nombre$, cat$
Dim d As Object

Set shListe = ThisWorkbook.Sheets(1)
Set d = CreateObject("Scripting.Dictionary")

'Si aucun commentaire. Le boolean sera Faux et quitte la procédure.
If shListe.Comments.Count = 0 Then blnComment = False: Exit Sub

'Sinon, boucle des commentaires de la feuille.
For Each Cmnt In shListe.Comments
    If Not Intersect(Cmnt.Parent, Range("J:V")) Is Nothing Then
      
        'Supprime les retours chariots et espaces dans le commentaire.
        Cells(Cmnt.Parent.Row, Cmnt.Parent.Column).Comment.Text Text:=Trim(Replace(Cmnt.Text, Chr(10), ""))
        'Récupère le nom inscrit dans le commentaire.
        'MsgBox Cmnt.Parent.Address
        nom = Cmnt.Text
        'Récupère le nombre.
        nombre = Cmnt.Parent.Value
        'Récupère la catégorie.
        cat = Cells(Cmnt.Parent.Row, "B").Value
        'Ajoute dans le dictionnaire.
        If Not d.exists(nom) Then
            d(nom) = cat & " " & nombre
            Else: d(nom) = d(nom) & "|" & cat & " " & nombre
        End If
    End If
Next Cmnt

Set dico = DicoTriKeysVal(d, 1)

'Passage du boolen à True
blnComment = True
End Sub

 

[Chri8Ed]

Bonjour Vgendron

Merci, c'est Ok
Je m'évertuais à faire le contraire
C'est à dire en utilisant IN pour regarder si les commentaires étaient dans la zone
Je comprends en même temps mieux maintenant l'utilisation de ce code
If Not Intersect(Cmnt.Parent, Range("J:V")) Is Nothing Then
Qui est quand même un peu déroutant, il faut le dire !

Si tu peux me donner un dernier coup de main
Je recherche le moyen de trier à l'inverse la ListBox lbNoms
C'est à dire de Z à A

J'arrive à le faire pour l'autre ListBox, mais pas celle-ci !!

A+

 

[vgendron]

Apparemment, tu as DEUX macros qui s'appellent tri
1) bizarre que vba ne t'envoie pas dans les roses...
2) dans une (celle qui tri la seconde listbox, tu ne spécifies PAS la colonne de tri, mais l'odre de tri 1 ou 0)
la colonne de tri étant calculée en interne de la fonction..

3) dans celle qui tri la première listbox: tu ne spécifies PLUS l'ordre de tri, mais la colonne de tri..
et ce que tu as laissé dans la fonction concerne en fait l'ordre croissant...

essaie ceci

Function DicoTriKeysVal(dico, colTri) As Object
  Dim d As Object
  Set d = CreateObject("scripting.dictionary")
  Dim Tbl(): ReDim Tbl(1 To dico.Count, 1 To 2)
  i = 0
  For Each c In dico.Keys
    i = i + 1
    Tbl(i, 1) = c: Tbl(i, 2) = dico(c)
  Next c
  tri Tbl, LBound(Tbl), UBound(Tbl), colTri, 0
  For i = LBound(Tbl) To UBound(Tbl)
    d(Tbl(i, 1)) = Tbl(i, 2)
  Next i
  Set DicoTriKeysVal = d
End Function

Sub tri(a, gauc, droi, colTri, ordre)        ' Quick sort  Ordre=1 Croissant/Ordre=0:décroissant
 ref = a((gauc + droi) \ 2, colTri)
 g = gauc: d = droi
 Do
    If ordre = 1 Then
   
    Else
     Do While a(g, colTri) > ref: g = g + 1: Loop
     Do While ref > a(d, colTri): d = d - 1: Loop
    End If
     If g <= d Then
       temp = a(g, 1): a(g, 1) = a(d, 1): a(d, 1) = temp
       temp = a(g, 2): a(g, 2) = a(d, 2): a(d, 2) = temp
       g = g + 1: d = d - 1
     End If
 Loop While g <= d
 If g < droi Then Call tri(a, g, droi, colTri, 0)
 If gauc < d Then Call tri(a, gauc, d, colTri, 0)
End Sub

 

[Chri8Ed]

Cela fonctionne à merveille
Merci
Je rencontre juste un problème
Quand je charge la ListiBox, Celle des noms (La 1ère donc)
Elle se repositionne là où je l'ai quittée
Donc elle garde en mémoire l'ancienne position
Alors que je voudrai qu'elle se charge au 1er nom trouvé
Tout en haut de la liste !
Mais là je ne sais pas si c'est possible ??
Si çà ne l'est pas, je me débrouillerai comme cela
Merci en tout cas pour ces 2 corrections
A+