"drag & drop" entre deux listview - bug de procédure !!

[CAPRI_456]

Bonsoir le Forum,


j'ai repris sur le Forum un fil nommé :"
Une réalisation associative Michel_M et @+Thierry, 27/06/2004 au sujet de drag and drop entre deux listbox
http://www.excel-downloads.com/forum/21499-demo-associative-userform-listbox-drag-n-drop-michel_m-thierry.html

j'ai adapté le code en changeant les références au "listbox" par les références aux "listviews"

Le code émet un bug:"La déclaration de procédure ne correspond pas à la description de l'événement ou de la procédure de même nom.

D'après l'aide , il semblerait que cela provienne d'utilisation répétitive d'évènements ou de noms de procédures, mais je ne vois pas où ?!?

Le fichier est joint ( le problème doit se situer dans le code de UserForm1)


Merci pour votre aide

CAPRI_456​

 

[CAPRI_456]

Re : "drag & drop" entre deux listview - bug de procédure !!

Bonsoir le Forum, Bebere,

J'examine ton code et je reviens sur le fil....

Bonne soirée à tous..

CAPRI_456

 

[CAPRI_456]

Re : "drag & drop" entre deux listview - bug de procédure !!

Bonsoir le Forum, Bebere,
1---- pour ma boucle

En examinant ton code, je vois une approche différente pour y arriver.
Mais pour mon projet, je n'ai pas besoin d'un scrutateur de répertoire
car c'est toujours dans le même (D:\ESSAIXLS) que je récupère les fichiers xls archivés.

Donc en laissant tomber cette recherche.. je vais droit au but..
le seul soucis que j'avais dans mon code vba au niveau du module = mod4_boucleClass est que je ne parviens pas à réaliser quelques actions spécifiques lors de ma boucle sur tous les fichiers de ce répertoire :
(pour le moment, la boucle m'affiche la première valeur des col respectives de chaque fichier) alors que je devrai obtenir.... en bleu dans le code ci-après

Set Wb = Workbooks.Open(Repertoire & Fichier)
Worksheets(1).Name = "Feuil1"

I = I + 1
'Récupère le contenu des colonnes...... dans chaque 1ere feuille des classeurs.... et sous la forme suivants.
Ws.Cells(I + 1, 9) = Wb.Worksheets(1).Range("F2") 'sectorOri
' 'la valeur qui apparait le plus souvent
Ws.Cells(I + 1, 10) = Wb.Worksheets(1).Range("D2") 'Produit
'la valeur qui apparait le plus souvent
Ws.Cells(I + 1, 11) = Wb.Worksheets(1).Range("B2") 'NbAWB
' le nombre total d'AWB
Ws.Cells(I + 1, 12) = Wb.Worksheets(1).Range("H2") 'Nb colis
' le nombre total de colis
Ws.Cells(I + 1, 13) = Wb.Worksheets(1).Range("J2") 'Poids
' le poids total Ws.Cells(I + 1, 14) = Wb.Worksheets(1).Range("K2") 'Volume
'le volume total
Ws.Cells(I + 1, 15) = Wb.Worksheets(1).Range("L2") 'Value
'la valeur totale Ws.Cells(I + 1, 16) = Fichier

'Referme le classeur
Wb.Close False


Donc, tu penses que cela ne fonctionnera pas sans modifier tout le code comme tu le suggères

II. pour l'imagelist

bien.... c'est un petit gadget,
si le code en colonne I est AMS,
il devrait afficher dans listview1 une icone drapeau NL


Merci des précisions

CAPRI_456

 

[Bebere]

Re : "drag & drop" entre deux listview - bug de procédure !!

bonjour Capri
une autre manière et les totaux

Sub boucle()
Dim Repertoire As String, Fichier

Dim Wb As Workbook
Dim Ws As Worksheet
Dim I As Integer

Application.ScreenUpdating = True

'Définit la Première feuille du classeur contenant cette macro
'(pour recevoir les donnée extraites dans les autres classeurs).
Set Ws = ThisWorkbook.Worksheets(1)
With Ws
fichierfeuil = .Range("P2" & .Range("P1000").End(xlUp).Row)
End With
'Définit le répertoire de recherche
'Set Dossier = "E:\essaisxlscapri\ESSAIXLS\"
'Spécifie la recherche pour le fichiers .xls
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder("D:\ESSAIXLS\") 'attention majuscule/minuscule
Set fc = f.Files


'Boucle sur les fichiers du répertoire
For Each f1 In fc
'Vérifie que le nom du classeur est différent du classeur
'contenant cette macro (dans le cas ou il serait placé dans le même répertoire).
If ThisWorkbook.Name <> Fichier Then
'Ouvre chaque classeur
If Right(f1, 4) = ".xls" Then
Set Wb = Workbooks.Open(f1)

I = I + 1
'Récupère le contenu de la cellule ...... dans chaque 1ere feuille des classeurs.
Ws.Cells(I + 1, 9) = Wb.Worksheets(1).Range("F2") 'sectorOri
Ws.Cells(I + 1, 10) = Wb.Worksheets(1).Range("D2") 'Produit
derl = Wb.Worksheets(1).Range("B1000").End(xlUp).Row
Ws.Cells(I + 1, 11) = Evaluate("Sum(B2:B" & derl & ")") 'NbAWB
Ws.Cells(I + 1, 12) = Evaluate("Sum(H2:H" & derl & ")") 'Nb colis
Ws.Cells(I + 1, 13) = Evaluate("Sum(J2:J" & derl & ")") 'Poids
Ws.Cells(I + 1, 14) = Evaluate("Sum(K2:K" & derl & ")") 'Volume
Ws.Cells(I + 1, 15) = Evaluate("Sum(L2:L" & derl & ")") 'Value
Ws.Cells(I + 1, 16) = Mid(f1, InStrRev(f1, "\") + 1)
'ce dernier(sert à vérifier qu'il y a bien équivalence entre les fichiers affihés dans Master et les fichiers screenés
'Referme le classeur
Wb.Close False

End If
End If

Next f1
Application.ScreenUpdating = True
MsgBox "Terminé"

End Sub

à bientôt

 

[CAPRI_456]

Re : "drag & drop" entre deux listview - bug de procédure !!

Le Forume, Bebere, bonjour,

La boucle proposée fonctionne parfaitement,,
mais les totaux ne s'appliquent pas sur mes fichiers (toujours la même valeur affcihée )

Je cherche sur le fil , la fonction Evaluate pour voir ce qui cloche 8

Bien à toi

A+

CAPRI_456

 

[CAPRI_456]

Re : "drag & drop" entre deux listview - bug de procédure !!

Bonsoir le Forum,

Avais testé sur un fichier archive durant ma pause ...
viens de tester sur mon masterfichier at home....

PArfait, cela boucle et totalise maintenant .

Encore merci Bebere , pour cette nouvelle approche.
----------------------------------------------------------------
Maintenant , je vais m'attaquer à l'IMAGELIST de la LISTVIEW pour afficher mes jolis drapeaux

Bonsoir le Fil
et merci pour ce support.

CAPRI_456

 

[Bebere]

Re : "drag & drop" entre deux listview - bug de procédure !!

Bonjour Capri

aide pour joli drapeau

Private Sub UserForm_Initialize()
Dim li As ListItem, L As Integer, Chemin As String
Dim Col As Byte, NbCol As Byte
Dim I As Long, k As Byte

Chemin = "E:\essaisxlscapri\ESSAIXLS\"
With ImageList1
'Supprime toutes les images de la liste
.ListImages.Clear
'Définit la dimension des images
.ImageHeight = 16 'Hauteur
.ImageWidth = 16 'Largeur
'Charge les nouvelles images
.ListImages.Add , "AMZ", LoadPicture(Chemin & "NL.ico")
End With

Set Me.ListView1.SmallIcons = Me.ImageList1
' Set Me.ListView1.Icons = Me.ImageList1
ListView1.ColumnHeaders.Clear
ListView2.ColumnHeaders.Clear

NbCol = 15

With Worksheets("Feuil1")
'entêtes pour les 2 listview
For Col = 1 To NbCol
ListView1.ColumnHeaders.Add , , .Cells(1, Col).Text, .Cells(1, Col).Width
ListView2.ColumnHeaders.Add , , .Cells(1, Col).Text, .Cells(1, Col).Width
Next Col
'contenu pour la listview1
For L = 2 To Application.CountA(Range("A:A")) '- 1
'1ère colonne
' Set li = ListView1.ListItems.Add(, , .Cells(L, 1).Text)
ListView1.ListItems.Add , , .Cells(L, 1).Text
I = ListView1.ListItems.Count ' + 1

'colonnes suivantes
For Col = 2 To NbCol ' - 1
Select Case Col
Case 8
ListView1.ListItems(I).ListSubItems.Add , , "", "AMZ"
Case Else
ListView1.ListItems(I).ListSubItems.Add , , .Cells(L, Col).Text
End Select

Next Col
Next L
End With

ListView1.View = lvwReport
ListView2.View = lvwReport
ListView1.FullRowSelect = True
ListView2.FullRowSelect = True
ListView1.Gridlines = True
ListView2.Gridlines = True
ListView1.MultiSelect = True
'autres propriétés listview
ListView1.CheckBoxes = True 'false
'ListView1.HideColumnHeaders = True 'false
'ListView1.ColumnHeaders =
' ListView1.ColumnHeaderIcons = Im1
'ListView1.AllowColumnReorder = True 'false ''permet le glisser/déplacer des colonnes
Me.Caption = TM

' For i = 2 To Sheets("Feuil1").Range("A65536").End(xlUp).L
' .ListItems.Add , , Sheets("Feuil1").Cells(i, 1)
' For k = 2 To 7
' .ListItems(.ListItems.Count).ListSubItems.Add , , Sheets("Feuil1").Cells(i, k)
' Next
' Next


Me.ListView1.CheckBoxes = True
'Vous pouvez ensuite indiquer le statut par défaut de la CheckBox.
'Si vous ne spécifiez pas ce paramètre, la case ne sera pas visible tout de suite:
'Vous devrez cliquer sur le bord gauche de la Ligne pour faire apparaitre la CheckBox.

Dim z As Integer

For z = 1 To ListView1.ListItems.Count
ListView1.ListItems(z).Checked = False
Next z

'drapeaux

End Sub


à bientôt

 

[CAPRI_456]

Re : "drag & drop" entre deux listview - bug de procédure !!

Bonjour le Forum, Bebere,

Mes jolis drapeaux s'affichent maintenant en col 8

Cependant, je voudrais qu'ils prennent la nationalité en fonction du code qui se trouve dans la colonne juste à côté (la 9) soit la "Key" dont les initiales sont reprises dans l'Imagelist3 pour identifier l'icône.

et donc je pense insérer une boucle sur chaque ligne comme suit


'--------------------------------------------------
'Boucle sur chaque ligne de la ListView pour attribuer l'icone qui correspond 'For X = 1 To .ListItems.Count
'Associe l'image ayant la clé (Key) "AMS". Cette image sera affichée
'lorsque la ListView sera en mode Icône
'.ListItems(X).Icon = "AMS"
'Associe l'image ayant la clé (Key) "Im3". Cette image sera affichée
'lorsque la ListView sera en mode petite Icône
'.ListItems(X).SmallIcon = "Im3"
'Next

Est-ce bien ainsi ...
Encore merci Bebere...
Capri_456

 

[Bebere]

Re : "drag & drop" entre deux listview - bug de procédure !!

bonjour Capri
trouvé une solution en consultant un fil de Chti
mais lui son dada,les trains
suite des jolis drapeaux

Private Sub UserForm_Initialize()
Dim Li As ListItem, L As Integer, Chemin As String
Dim Col As Byte, NbCol As Byte, Pays As String
Dim I As Long, k As Byte

Chemin = "E:\essaisxlscapri\ESSAIXLS\"
With ImageList1
'Supprime toutes les images de la liste
.ListImages.Clear
'Définit la dimension des images
.ImageHeight = 16 'Hauteur
.ImageWidth = 16 'Largeur
'Charge les nouvelles images
.ListImages.Add , "eu", LoadPicture(Chemin & "etats-unis.ico")
.ListImages.Add , "nz", LoadPicture(Chemin & "nouvelle-zelande.ico")
.ListImages.Add , "ru", LoadPicture(Chemin & "royaume-uni.ico")
.ListImages.Add , "AMZ", LoadPicture(Chemin & "NL.ico")
End With

Set Me.ListView1.SmallIcons = Me.ImageList1
' Set Me.ListView1.Icons = Me.ImageList1
ListView1.ColumnHeaders.Clear
ListView2.ColumnHeaders.Clear

NbCol = 15

With Worksheets("Feuil1")
'entêtes pour les 2 listview
For Col = 1 To NbCol
ListView1.ColumnHeaders.Add , , .Cells(1, Col).Text, .Cells(1, Col).Width
ListView2.ColumnHeaders.Add , , .Cells(1, Col).Text, .Cells(1, Col).Width
Next Col
'contenu pour la listview1
For L = 2 To Application.CountA(Range("A:A")) '- 1
'1ère colonne
Set Li = ListView1.ListItems.Add(, , .Cells(L, 1).Text)

'colonnes suivantes
For Col = 2 To NbCol ' - 1
Select Case Col
Case 8
Pays = .Cells(L, 9).Text
Select Case Pays
Case "eu"
Li.ListSubItems.Add , , "", "eu"
Case "nz"
Li.ListSubItems.Add , , "", "nz"
Case "ru"
Li.ListSubItems.Add , , "", "ru"
Case "AMZ"
Li.ListSubItems.Add , , "", "AMZ"
End Select

Case Else
Li.ListSubItems.Add , , .Cells(L, Col).Text
End Select
Next Col
Next L
End With

ListView1.View = lvwReport
ListView2.View = lvwReport
ListView1.FullRowSelect = True
ListView2.FullRowSelect = True
ListView1.Gridlines = True
ListView2.Gridlines = True
ListView1.MultiSelect = True
'autres propriétés listview
ListView1.CheckBoxes = True 'false
'ListView1.HideColumnHeaders = True 'false
'ListView1.ColumnHeaders =
' ListView1.ColumnHeaderIcons = Im1
'ListView1.AllowColumnReorder = True 'false ''permet le glisser/déplacer des colonnes
Me.Caption = TM

' For i = 2 To Sheets("Feuil1").Range("A65536").End(xlUp).L
' .ListItems.Add , , Sheets("Feuil1").Cells(i, 1)
' For k = 2 To 7
' .ListItems(.ListItems.Count).ListSubItems.Add , , Sheets("Feuil1").Cells(i, k)
' Next
' Next


Me.ListView1.CheckBoxes = True
'Vous pouvez ensuite indiquer le statut par défaut de la CheckBox.
'Si vous ne spécifiez pas ce paramètre, la case ne sera pas visible tout de suite:
'Vous devrez cliquer sur le bord gauche de la Ligne pour faire apparaitre la CheckBox.

Dim z As Integer

For z = 1 To ListView1.ListItems.Count
ListView1.ListItems(z).Checked = False
Next z

'drapeaux

End Sub
à bientôt

 

[CAPRI_456]

jolis drapeaux dans imagelist

Bonjour, le Forum, Bebere,

Merci pour ces jolis drapeaux,
j'avais parcouru "les trains" de Chti , mais ne voyais pas comment l'appliquer...

une question:
faut-il absolument passer par un chargement des images dans imagelist par le code vba
...où peut on charger en permanence les images ( +- 50 ico) dans l'imagelist et y faire appel lorsque la cléf correspond au code en col 9

sinon mon code va gofler de 50 lignes du style
'Charge les nouvelles images
.ListImages.Add , "eu", LoadPicture(Chemin & "etats-unis.ico")

Merci Bebere,

Bonne fin de journée

CAPRI_456

 

[CAPRI_456]

Re : "drag & drop" entre deux listview - bug de procédure !!

Bonsoir le Forum, Bebere,

je reprend après un break d'été bien mérité... comme je le souhaite à vous tous BIEN NATURELLEMENT

AU sujet de drag and drop, in fine , j'ai abandonné cette piste et remplacé mes glisser-déplacer par un cochage en colonne 1
(en effet ,le drag and drop , n'était pas maitrisable, un simple passage sur la ligne et hop elle passait d'une listview à l'autre = trop risqué)

Avantage du cochage, il visualise bien la ligne en gras et en bleu lors du transfert et avec une inputbox , je puis introduire des datas complémentaires.

J'ai cependant un soucis:
lorsque je fais passer mes lignes de List 1 à List2 c'est ok , mais lorsque je fais un retour en arrière, c'est aussi OK, mais les lignes ne retrouvent pas leurs postions intitiales elles crèent un nouveau bloc en dessous et il subsiste alors des vides...
idéalement le remplacement dans l'ordre (et sans vides) serait l'idéal...
Est-ce un problèmes d'index...?

autre: puisqu'il ne s'agit plus de "drag and drop" dois-je créer un nouveau fil : "transfert entre listviews" par exemple ??


Merci
CAPRI_456