Re : "drag & drop" entre deux listview - bug de procédure !!
bonjour Capri
un début de code,pour la suite je ne comprend pas ce que tu veux
j'ai mis un commentaire
'Attribute VB_Name = "Mod_boucleClass"
Sub TousFichiersDunDossier()
Dim Fso As Object, Dossier As Object, NomDossier
Dim Files As Object, File As Object, I As Integer
Dim WkSource As Workbook, WsDest As Worksheet, Nom As String
Set Fso = CreateObject("Scripting.FileSystemObject")
NomDossier = ChoisirDossier
If NomDossier = "" Then Exit Sub
Set Dossier = Fso.getfolder(NomDossier)
Set WsDest = ThisWorkbook.Worksheets(1)
With WsDest
fichierfeuil = .Range("P2
" & .Range("P1000").End(xlUp).Row)
End With
Set Files = Dossier.Files
If Files.Count <> 0 Then
' Sheets.AddLeft(fichierfeuil(I, 1), Len(fichierfeuil(I, 1)) - 4)
For Each File In Files
Nom = File.Name
For I = 1 To UBound(fichierfeuil)
If Right(Nom, 4) = ".xls" Then
If UCase(Nom) = UCase(fichierfeuil(I, 1)) Then
Set WkSource = Workbooks.Open(File.Name)
With WsDest'içi,explique ce que tu veux
.Cells(I, "I").Value = WsSource.ActiveSheet.Cells(I, "D").Value
.Cells(I, "J").Value = WsSource.ActiveSheet.Cells(I, "F").Value
.Cells(I, "K").Value = WsSource.ActiveSheet.Cells(I, "H").Value
.Cells(I, "L").Value = WsSource.ActiveSheet.Cells(I, "J").Value
.Cells(I, "M").Value = WsSource.ActiveSheet.Cells(I, "K").Value
.Cells(I, "O").Value = WsSource.ActiveSheet.Cells(I, "L").Value
.Cells(I, "P").Value = File.Name
End With
ActiveWorkbook.Close savechanges = False
End If
End If
Next I
Next File
End If
End Sub
Function ChoisirDossier()
Dim objShell, objFolder, chemin, SecuriteSlash
Set objShell = CreateObject("Shell.Application")
Set objFolder = _
objShell.BrowseForFolder(&H0&, "Choisisser un répertoire", &H1&)
On Error Resume Next
chemin = objFolder.ParentFolder.ParseName(objFolder.Title).Path & ""
If objFolder.Title = "Bureau" Then
chemin = "C:\Windows\Bureau"
End If
If objFolder.Title = "" Then
chemin = ""
End If
SecuriteSlash = InStr(objFolder.Title, ":")
If SecuriteSlash > 0 Then
chemin = Mid(objFolder.Title, SecuriteSlash - 1, 2) & ""
End If
ChoisirDossier = chemin
End Function
'ton code
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 = "D:\ESSAIXLS\"
'Spécifie la recherche pour le fichiers .xls
Set Fichier = Repertoire.Files
'Boucle sur les fichiers du répertoire
Do While Fichier <> ""
'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
Set Wb = Workbooks.Open(Repertoire & Fichier)
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
Ws.Cells(I + 1, 11) = Wb.Worksheets(1).Range("B2") 'NbAWB
Ws.Cells(I + 1, 12) = Wb.Worksheets(1).Range("H2") 'Nb colis
Ws.Cells(I + 1, 13) = Wb.Worksheets(1).Range("J2") 'Poids
Ws.Cells(I + 1, 14) = Wb.Worksheets(1).Range("K2") 'Volume
Ws.Cells(I + 1, 15) = Wb.Worksheets(1).Range("L2") 'Value
Ws.Cells(I + 1, 16) = Fichier
'ce dernier(sert à vérifier qu'il y a bien équivalence entre les fichiers affihés dans Master et les fichiers screenés
à bientôt
