Discussion :

[Anthonydu62]

Bonjour à toutes et tous.
Voila, depuis un certain temps (un temps certain...) je dois tous les mois faire une extraction d'un pro-logiciel et renommer les fichiers pour les envoyer à la direction.
Cela me prend beaucoup de mon temps (dans mon exemple j'ai mis 5 lignes d'information, en réalité, j'en ai plus de 350 lignes).
J'aurais voulu savoir:
A partir du tableau excel


En VBA, rechercher les 7 premiers caractères présent sur la colonne A (Origine) correspondant au 7 premiers caractères des fichiers ce trouvant dans un dossier, et si il y a correspondance, le renommer du nom contenu dans la colonne B, C,D ou E...
Pour information, je suis une quiche en VBA.
Merci de votre aide.
Anthony

[Invité]

Essaie ce code, entrer le nom de ta feuille actuellement il est configuré à Feuil1
Entrer aussi le chemin de rechercher pour les fichiers

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Sub ChangerNoms()
Dim i As Long, nPos As Long
Dim Dic As New Collection
Dim nName As String, nNew As String, Ext As String
Dim oDossier, oFile, fso As Object
oDossier = "C:\Users\pc\Desktop\fld"
With Worksheets("Feuil1")
  For i = 2 To .Cells(Rows.Count, "A").End(xlUp).Row
      nName = Left(.Cells(i, "A"), 7)
      Dic.Add i, UCase(nName)
  Next
  Set fso = CreateObject("Scripting.Filesystemobject")
  For Each oFile In fso.GetFolder(oDossier).Files
     nName = fso.GetBaseName(oFile.Name)
     nName = Left$(nName, 7)
     On Error Resume Next
     nPos = Dic(UCase(nName))
     If Err.Number = 0 Then
       Ext = fso.GetExtensionName(oFile.Name)
       If Ext <> "" Then: Ext = "." & Ext
       nNew = oFile.ParentFolder & "\" & .Cells(nPos, "B") & Ext
       oFile.Move nNew
     Else
       Err.Clear
     End If
     On Error GoTo 0
  Next
End With
 
End Sub

[Anthonydu62]

Je viens de tester, il affiche une erreur:

Erreur d'exécution 457:
Cette clé est déjà associé à un élément de cette collection.

Pour moi c'est du charabia.

En tout cas merci pour ton aide.

[Anthonydu62]

J'ai supprimé la première ligne de le feuille excel et là une autre erreur:

Erreur d'exécution 5:
Argument ou appel de procédure incorrect.

[tototiti2008]

Bonjour,

Moi je n'ai pas tout compris
Les fichiers doivent être renommés dans les noms de toutes les colonnes remplies ou la dernière remplie ?
pourquoi les colonnes vides on des - dedans, le - est-il tapé ?

[Anthonydu62]

pour démarrer, si on y arrive avec les colonne A et B, je serais heureux.

Oui les - sont tapés, c'est en format texte.

[tototiti2008]

Re,

Sinon, à la question

Les fichiers doivent être renommés dans les noms de toutes les colonnes remplies ou la dernière remplie ?

quelle est la réponse ?

[Anthonydu62]

La colonne A c'est le nom des fichiers d'origine créés par un logiciel.
Les colonnes B, C, D... sont les mois des extractions.
Pour faire plus simple, au mois de mai, c'est tel nom, au mois de juin....

On peu faire plus simple si vous voulez en prenant en compte qu'1 seul mois. Après je n'aurais qu'a faire un copier collé.

[Invité]

Cette clé est déjà associé à un élément de cette collection.

Cela veut dire qu'il y a un doublon dans la colonne A, deux éléments ont les mêmes sept premières lettres.

[Anthonydu62]

Effectivement, il y avait un doublon du a une erreur de saisie de ma part pour les tests.

Le problème maintenant, c'est qu'il fait le travail mais uniquement pour la dernière ligne.
J'ai mis des MsgBox pour voir, il lis pourtant bien toutes les lignes du tableau.
Mais ne fait le changement que pour la dernière.

[Invité]

Je viens de corriger l'erreur un oubli ou mauvaise manip :On Resume Next doit être placé avant la ligne de test de existence dans la collection

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Sub ChangerNoms()
Dim i As Long, nPos As Long
Dim Dic As New Collection
Dim nName As String, nNew As String, Ext As String
Dim oDossier, oFile, fso As Object
oDossier = "C:\Users\pc\Desktop\fld"
With Worksheets("Feuil1")
  For i = 2 To .Cells(Rows.Count, "A").End(xlUp).Row
      nName = Left(.Cells(i, "A"), 7)
      Dic.Add i, UCase(nName)
  Next
  Set fso = CreateObject("Scripting.Filesystemobject")
  For Each oFile In fso.GetFolder(oDossier).Files
     nName = fso.GetBaseName(oFile.Name)
     On Error Resume Next
     nPos = Dic(UCase(nName))
     If Err.Number = 0 Then
       Ext = fso.GetExtensionName(oFile.Name)
       If Ext <> "" Then: Ext = "." & Ext
       nNew = oFile.ParentFolder & "\" & .Cells(nPos, "B") & Ext
       oFile.Move nNew
     Else
       Err.Clear
     End If
     On Error GoTo 0
  Next
End With
 
End Sub

Remarque importante :le code actuel compare le nom complet du fichier avec les sept premières lettres des éléments de la colonne A, si la longueur du nom du fichier est variable et dépasse les sept lettres alors ajouter cette ligne pour ne comparer que les sept lettres:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
    nName = fso.GetBaseName(oFile.Name)
     nName = Left$(nName, 7) 'Ajouter cette ligne 
     On Error Resume Next

[tototiti2008]

re,

Devrait renommer les fichiers colonne A en colonne B (dossier à adapter)

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
Sub RenommFic()
Dim Doss As String, Liste, i As Long, Fic As String, Ext As String
    Doss = "C:\Users\toto\Desktop\aa\" 'dossier des fichiers à renommer
    Liste = Range("A1").CurrentRegion.Value
    For i = 2 To UBound(Liste, 1)
        Fic = Dir(Doss & Left(Liste(i, 1), 7) & "*")
        If Fic <> "" Then
            Ext = Mid(Fic, InStrRev(Fic, ".") + 1, 10000)
            Name Doss & Fic As Doss & Liste(i, 2) & "." & Ext
        End If
    Next i
End Sub