[XL-365] Renommer des fichiers, sans ouverture, en supprimant les 7 1ers caractères

Renommer des fichiers, sans ouverture, en supprimant les 7 1ers caractères

Bonjour

J'ai écrit une macro qui sauvegarde mes fichiers en les renommant avec la date du jour (AAMMJJ et espace = 7).

Je voudrais pouvoir restaurer l'ensemble de ces fichiers en supprimant la date et en les déplaçant dans un autre répertoire ; le tout sans les ouvrir bien sûr ;>

Est-ce que qq'1 peut m'aider, svp

Bonjour,

tu peux utiliser la syntaxe disponible dans la :faq:

https://excel.developpez.com/faq/?pa...RenommeFichier

Code:

Name AncienNom As NouveauNom

Hello Mouftie,

Tu peu tester ceci, essaie d'abord dans deux dossiers test ;-)
Attention à bien modifier la ligne 10 , nombre de caractère a supprimer à Droite.

Code:

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
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
Sub Mouftie()
 
Dim varFileName As Variant
Dim FolderSource As String
Dim FolderCible As String
Dim NbCharToDeleteinName As Integer
Dim Fdbck As String
 
'A modifier par tes valeurs
 NbCharToDeleteinName = 7   'On supprimera les 7 premiers caratères a droite du nom de fichier
 
'On touche pas (Récupération des Dossier Source et Cible)
 
 FolderSource = SelectFolder("Sélectionner le Dossier SOURCE")
 FolderCible = SelectFolder("Selectionner le Dossier de DEST")
 
 If Len(FolderSource) > 0 And Len(FolderCible) > 0 Then 'On vérifie que deux dossier ont bien été selectionné
 
    varFileName = ListFilesInFolder(Path:=FolderSource) 'On liste dans la variable varFileName TOUS les fichiers contenu dans le Fichier source
 
    If UBound(varFileName) = 0 Then 'Test si dossier Source est vide
      Fdbck = "Le Dossier source ne contient aucun fichier"
    Else
      For i = LBound(varFileName) To UBound(varFileName) - 1
        If Not FileExist(FolderCible & Mid(varFileName(i), NbCharToDeleteinName)) Then
           Name FolderSource & varFileName(i) As FolderCible & Mid(varFileName(i), NbCharToDeleteinName)
        Else
           Fdbck = Fdbck & "Le Fichier " & Mid(varFileName(i), NbCharToDeleteinName) & " existe déjà dans le dossier de destination." & vbNewLine
        End If
      Next i
    End If
 Else
   Fdbck = "Souci dans la sélection des Dossiers"
 End If
 
 MsgBox IIf(Fdbck <> "", Fdbck, "Transfert Ok")
 
End Sub
 
Function SelectFolder(ByVal title As String) As String
 
  With Application.FileDialog(msoFileDialogFolderPicker)
      .title = title
      If .Show = -1 Then ' if OK is pressed
            SelectFolder = .SelectedItems(1) & "\"
      End If
  End With
 
End Function
 
Function FileExist(ByVal Path As String) As Boolean
 FileExist = IIf(Len(Dir(Path)) > 0, True, False)
End Function
 
Function ListFilesInFolder(ByVal Path As String) As Variant
 ListFilesInFolder = Split(CreateObject("WScript.Shell").Exec("cmd /c dir """ & Path & """ /B").StdOut.ReadAll, vbNewLine)
End Function

Bàt,

Bonjour à vous deux et merci pour vos réponses.

mfoxy, tu as fait un sacré boulot, mais je ne peux pas l'utiliser (je ne sais pas corriger) car je veux supprimer le début du nom de fichier, donc à gauche et non la fin à droite. Mais je sais où réutiliser ton travail. un grand merci

Du coup, j'ai pris la solution de Jean-Philippe

Re Mouftie,

Mea Culpa, la macro retire les 7 premiers caractères :ptdr:

Bonne journée,