classement par nom

[akramenergie]

bonjour tous le monde
j'ai besoin d'un coup de main svp les gas
je doit faire un tri suivant les nom des foto que j'ai dans un répertoire
je m'explique
je recoit des centaine de foto de diférente fournisseur ces foto son nomé par leur marque ce ke je doi faire moi c une macro qui lit les nom de ces foto et les classe dans des dossier qui porte le non du fournisseur, et dans la premeire feuil d'excel il note le nombre de foto qu'il a classer pour chaque fournisseur dans ces dossier. l'exemple suivant est un cas de ce que je veut fair
dans le ficher que j'ai mi en piéce joint il ya 3 foto
2 de hyandai et 1 de siera
lorsque je doi lancer ma macro il va faloire créé un dossier nomé siéra et mettre la foto siera dans ce dossier
et créé un autre dossier nomé hyandai et mettre les deux foto hyandai dans ce dossier


NB: je recoi chaque semaine un cd de 1Go de foto donc je vous laisse imaginer le travail qui faut
merci d'avance les gas

 

[fanfan38]

Re : classement par nom

Bonjour
Il faut d'abord lister les fichiers: pour ce faire une appli de myDearFriend! que tu trouveras dans ce topic
https://www.excel-downloads.com/thr...-excel-des-musiques-de-mon-dossier-mp3.93518/
ensuite un trie par nom de fichier
ensuite on compte les fichier dont la partie gauche du mot est identique (fonction nb.si)
Bon courage
Je dois aller au boulot

A+ François

 

[akramenergie]

Re : classement par nom

oui mai moi mon soussi c de placer les foto dnas un mm dossier qui porte leur nom???
comment faire svp

 

[fanfan38]

Re : classement par nom

Je pense que c'est faisable de modifier le chemin

A+ François

 

[bqtr]

Re : classement par nom

Bonjour akramenergie, fanfan

Pour lister les fournisseurs de photos et le nombre de photos:
(Le chemin du repertoire est à adapté)
à BOISGONTIER pour le "Scripting Dictionary"

Sub Liste_Fichier()
Dim FSO As Scripting.FileSystemObject
Dim Rep As Scripting.Folder
Dim Fich As Scripting.File
Dim Pos As Integer
Dim Fournisseur
Dim Temp
On Error GoTo Fin
Set FSO = New Scripting.FileSystemObject
Set Rep = FSO.GetFolder(ThisWorkbook.Path & "\Photos")
Set Fournisseur = CreateObject("Scripting.Dictionary")
Range("A2:B" & Range("A65536").End(xlUp).Row + 1).Clear
   
    For Each Fich In Rep.Files
      Pos = InStr(1, Fich.Name, "_")
         If Not Fournisseur.Exists(Left(Fich.Name, Pos - 1)) Then
            Fournisseur.Add Left(Fich.Name, Pos - 1), 1
         Else
            Temp = Fournisseur.Item(Left(Fich.Name, Pos - 1))
            Fournisseur.Remove (Left(Fich.Name, Pos - 1))
            Fournisseur.Add Left(Fich.Name, Pos - 1), Temp + 1
         End If
    Next
  Range("A2").Resize(Fournisseur.Count, 1) = Application.Transpose(Fournisseur.Keys)
  Range("B2").Resize(Fournisseur.Count, 1) = Application.Transpose(Fournisseur.Items)
   
Set FSO = Nothing
Set Rep = Nothing
Set Fournisseur = Nothing
Exit Sub
Fin:
MsgBox "Une erreur s'est produite, vérifier :" & vbCrLf & _
       "- le nom des fichiers" & vbCrLf & _
       "- le nom des répertoires" & vbCrLf & _
       "- .../...", vbCritical, "Erreur"
Set FSO = Nothing
Set Rep = Nothing
Set Fournisseur = Nothing
End Sub

Il faut dans le menu VBA Outils/Références coché la case "Microsoft Scripting Runtime"

Pour le reste de ta question( si j'y arrive ), il faudrait que tu précises un peu:
Les fournisseurs sont toujours les mêmes ?
Que fais tu des anciennes photos, tu les suprrimes ?
Sinon tu ajoutes les nouvelles dans les mêmes dossiers ou dans des nouveaux ?

Précise le plus précisément comment tu procédes .

Bonne journée

 

[bqtr]

Re : classement par nom

Re,

Voici une proposition pour le transfert :

1: Faire la liste des fournisseurs et du nombre des photos (Bouton Liste Fournisseurs)
2: Faire le transfert (Bouton Transfert Fichiers)

La 2ème macro procède à la création des dossiers fournisseurs (dans le répertoire Fournisseurs) si ils n'existent pas.

Elle crée ensuite les dossiers de destination des photos dans chaque dossier Fournisseur (le nom du fournisseur + un espace + la date du jour).

Enfin elle transfert chaque photo du répertoire photos dans son dossier de destination.

A+

 

[akramenergie]

merci sa marche parfaitement
super

 

[akramenergie]

Re : classement par nom

juste une derniere chose
la macro marche parfaitement
mais il ya just un tou peti problém
l'orsque je lansse la macro pour la premiere fois elle marche bien
et si je recoi d'autre foto je les enregistre je lance ma macro il ya une erreur qui apparait et qui me me dit que comme quoi ce dossier et deja créé
si j'ai bien compris il ya une parti dans le code qui créé les dossier des fournisseur : moi j ai pensser a faire un if avant la création des dossier cad si les dossier son déja créé il met juste en place les foto dans leur dossier des fournisseur concérner mai j'arive pa a trouver cette partie qui traite la création des dossier
vue mon niveaux débutant en vba
merci les gas de m'aider pour ce dérnier probleme concérnent cette macro

 

[bqtr]

Re : classement par nom

Bonsoir,

Je viens de faire plusieurs transferts successifs sans erreur.
Les dossiers fournisseurs et sous dossiers fournisseurs ne sont créés que si ils n'existent pas.
Donc le problème ne se trouve pas là.

Le problème survient sur la première (liste fournisseurs) ou la deuxième macro (Transfert)?

As tu un n° d'erreur 58,76,13..... sur le message d'erreur ?

J'ai trouvé un problème, c'est l'existance d'un fichier système caché : Thumbs.db qui provoque une erreur si il est présent dans le répertoire photo.

Il est possible de ne pas créer de sous dossier fournisseur mais dans ce cas il risque d'y avoir un problème de doublon des noms de photos. (vu le nom des photos)

A te lire

A+

 

[bqtr]

Re : classement par nom

Re,

Est ce que le nom des photos a une importance ?

Tu souhaites un seul dossier par fournisseur avec toutes les photos ou bien un dossier par fournisseur avec à l'intérieur à chaque fois un sous dossier par transfert ?

A+

 

[akramenergie]

Re : classement par nom

en faite j'aimerais bien que j'ai un dossier par fournisseur qui contient les foto de ce fournisseur !!!!!

 

[akramenergie]

Re : classement par nom

stop le probleme c plus la création le méme comme vous disait vous aver réson ya pas de bug moi ja mal compris l'operation on doit pa le faire deux fois le méme jours
mais si non tou marche comme prévue
la question que jai maintenent pour quoi dans la feuil on arive pas a grder les méme valeur que par avant et on rajout le nouveux foto

 

[bqtr]

Re : classement par nom

Re,

Pour les données des colonnes A et B c'est normal, elles servent à lister les fournisseurs et le nombre de photo du répertoire Photos.
Cela permet de rajouter les nouveaux fournisseurs si le cas se présente.
Elles sont effacées au lancement de la macro "Liste_Fichier".

Remplace la macro "Transfert" du fichier par celle-ci :

Sub Transfert()
 
Dim FSO As Scripting.FileSystemObject
Dim RepF As Scripting.Folder
Dim RepPh As Scripting.Folder
Dim SousRepF As Scripting.Folder
Dim Fournisseurs As Scripting.Folder
Dim Fich As Scripting.File
Dim k As Long, x As Long, M As Integer
Dim Pos As Integer
Dim Tablo()
 
If Range("A2") = "" Then
 MsgBox "Faire la liste des fournisseurs avant le transfert des fichiers", vbExclamation, "Erreur"
 Exit Sub
End If
 
Set FSO = New Scripting.FileSystemObject
Set RepPh = FSO.GetFolder(ThisWorkbook.Path & "\Photos")
Set Fournisseurs = FSO.GetFolder(ThisWorkbook.Path & "\Fournisseurs")
 
For k = 2 To Range("A65356").End(xlUp).Row
  If Not FSO.FolderExists(Fournisseurs.Path & "\" & Range("A" & k)) Then
     Set RepF = FSO.CreateFolder(Fournisseurs.Path & "\" & Range("A" & k))
  End If
Next
 
For Each Fich In RepPh.Files
     If Fich.Name <> "Thumbs.db" Then
        Pos = InStr(1, Fich.Name, "_")
        Fich.Move (Fournisseurs.Path & "\" & Left(Fich.Name, Pos - 1) & "\" & Fich.Name)
     End If
Next
 
x = 0
 
For Each SousRepF In Fournisseurs.SubFolders
   ReDim Preserve Tablo(2, x)
      For Each Fich In SousRepF.Files
        If Fich.Name <> "Thumbs.db" Then
           M = M + 1
        End If
      Next
   Tablo(0, x) = SousRepF.Name
   Tablo(1, x) = M
   M = 0
   x = x + 1
Next
 
Range("D2").Resize(UBound(Tablo, 2) + 1, UBound(Tablo, 1)) = Application.Transpose(Tablo)
 
Set FSO = Nothing
Set RepPh = Nothing
Set Fournisseur = Nothing
Set RepF = Nothing
 
 
End Sub

Puis la macro "Liste_Fichier" comme ceci:

.../...
 For Each Fich In Rep.Files
      If Fich.Name <> "Thumbs.db" Then
         Pos = InStr(1, Fich.Name, "_")
            If Not Fournisseur.Exists(Left(Fich.Name, Pos - 1)) Then
               Fournisseur.Add Left(Fich.Name, Pos - 1), 1
            Else
               Temp = Fournisseur.Item(Left(Fich.Name, Pos - 1))
               Fournisseur.Remove (Left(Fich.Name, Pos - 1))
               Fournisseur.Add Left(Fich.Name, Pos - 1), Temp + 1
            End If
      End If
    Next
.../...

Les modifs :

- Le cas du fichier Thumbs est réglé.
- Tu n'as plus de sous dossier fournisseur: un fournisseur un dossier
- Rien ne t'empêche de faire plusieurs transferts à la suite. Le seul problème c'est le risque de doublon dans les noms de fichier.
- En D1 tu mets par exemple "Fournisseur", en E1 "Nombre de photo". La macro te mettra en D2:Exxx le nom des fournisseurs et le nombre total de photo de chaque dossier. Les données seront réactualisées à chaque transfert.

A+