XL 2010 VAB - Lister et renommer fichiers en bloc

[tchi456]

Bonjour,

J'ai un code pour pouvoir lister et renommer des fichiers en bloc mais je n'arrive pas à l'adapter pour ma nouvelle feuille Excel.

Pour la fonction lister:
Je souhaiterais qu'il n'ouvre pas une fenêtre de dialogue mais qu'il reprenne automatiquement le chemin d'accès du dossier de la cellule A2 et qu'il liste mes fichier en A3:A1000.

Pour la fonction renommer:
Il y a un bug que je n'arrive pas à résoudre mais je souhaiterais qu'il renomme les fichiers des cellules A3:A1000 selon les nouveaux noms indiqués dans les cellules I3:I1000.

Pouvez-vous m'aider? Je vous joins le fichier comme exemple.

Mes meilleures salutations et bon début de semaine.

Thierry

 

[Dranreb]

Bonjour.
J'écrirais probablement tout ça comme ça :

Option Explicit
Sub Lister()
   Dim T(), Fic As String, L As Long
   On Error Resume Next
   ChDrive [A2].Value: ChDir [A2].Value
   If Err Then MsgBox Err.Description, vbCritical, "Lister": Exit Sub
   On Error GoTo 0
   ActiveSheet.Unprotect "."
   ReDim T(1 To 1000, 1 To 1)
   Fic = Dir("*")
   Do While Fic <> ""
      L = L + 1
      T(L, 1) = Fic
      Fic = Dir
      Loop
   [A3].Resize(1000).Value = T
   ActiveSheet.Protect "."
   End Sub
Sub Renommer()
   Dim TOrig(), TReno(), L As Long
   TOrig = [A3].Resize([A1005].End(xlUp).Row - 2).Value
   TReno = [I3].Resize(UBound(TOrig, 1)).Value
   On Error Resume Next
   ChDrive [A2].Value: ChDir [A2].Value
   If Err Then MsgBox Err.Description, vbCritical, "Lister": Exit Sub
   For L = 1 To UBound(TOrig, 1)
      If TReno(L, 1) <> TOrig(L, 1) And Not IsEmpty(TReno(L, 1)) Then
      Err.Clear: Name TOrig(L, 1) As TReno(L, 1)
      If Err Then MsgBox "Name """ & TOrig(L, 1) & """ As """ & TReno(L, 1) & """" _
         & vbLf & Err.Description, vbExclamation, "Renommer"
      Next L
   End Sub

 

[tchi456]

Bonjour Dranreb,

Merci pour votre proposition; la fonction "Lister" fonctionne parfaitement bien et je vous en remercie mais j'ai malheureusement une erreur sur la fonction "Renommer":

Meilleures salutations,

Thierry

 

[Dranreb]

Ah, je n'ai pas pu tester. Un End If oublié.

Sub Renommer()
   Dim TOrig(), TReno(), L As Long
   TOrig = [A3].Resize([A1005].End(xlUp).Row - 2).Value
   TReno = [I3].Resize(UBound(TOrig, 1)).Value
   On Error Resume Next
   ChDrive [A2].Value: ChDir [A2].Value
   If Err Then MsgBox Err.Description, vbCritical, "Lister": Exit Sub
   For L = 1 To UBound(TOrig, 1)
      If TReno(L, 1) <> TOrig(L, 1) And Not IsEmpty(TReno(L, 1)) Then
         Err.Clear: Name TOrig(L, 1) As TReno(L, 1)
         If Err Then MsgBox "Name """ & TOrig(L, 1) & """ As """ & TReno(L, 1) & """" _
            & vbLf & Err.Description, vbExclamation, "Renommer"
         End If
      Next L
   End Sub

 

[job75]

Bonjour tchi456, Bernard,

Une seule macro suffit :

Sub Renommer()
Dim chemin$, fso As Object, lig&, f As Object, nom$, ext$
chemin = ThisWorkbook.Path & "\Test\"
If Dir(chemin, vbDirectory) = "" Then MkDir chemin 'si le sous-dossier n'existe pas il est créé
[A2] = chemin
Set fso = CreateObject("Scripting.FileSystemObject")
lig = 2
Application.ScreenUpdating = False
Range("A3:A" & Rows.Count).ClearContents 'RAZ
For Each f In fso.Getfolder(chemin).Files
    lig = lig + 1
    nom = f.Name
    Cells(lig, 1) = nom
    ext = Mid(nom, InStrRev(nom, "."))
    If Cells(lig, 9) <> "" Then Name chemin & nom As chemin & Cells(lig, 9) & ext 'renomme le fichier
Next
End Sub

Si le sous-dossier 'Test" n'existe pas il est créé.

Mettez-y les fichiers à renommer.

Edit : je ne m'occupe pas de la protection de la feuille car elle ne sert à rien.

A+

 

[job75]

Ou en utilisant la fonction Dir :

Sub Renommer()
Dim chemin$, fichier$, lig&, ext$
chemin = ThisWorkbook.Path & "\Test\"
If Dir(chemin, vbDirectory) = "" Then MkDir chemin 'si le sous-dossier n'existe pas il est créé
[A2] = chemin
fichier = Dir(chemin & "*.*")
lig = 2
Application.ScreenUpdating = False
Range("A3:A" & Rows.Count).ClearContents 'RAZ
While fichier <> ""
    lig = lig + 1
    Cells(lig, 1) = fichier
    ext = Mid(fichier, InStrRev(fichier, "."))
    If Cells(lig, 9) <> "" Then Name chemin & fichier As chemin & Cells(lig, 9) & ext 'renomme le fichier
    fichier = Dir
Wend
End Sub

 

[tchi456]

Ah, je n'ai pas pu tester. Un End If oublié.

Sub Renommer()
   Dim TOrig(), TReno(), L As Long
   TOrig = [A3].Resize([A1005].End(xlUp).Row - 2).Value
   TReno = [I3].Resize(UBound(TOrig, 1)).Value
   On Error Resume Next
   ChDrive [A2].Value: ChDir [A2].Value
   If Err Then MsgBox Err.Description, vbCritical, "Lister": Exit Sub
   For L = 1 To UBound(TOrig, 1)
      If TReno(L, 1) <> TOrig(L, 1) And Not IsEmpty(TReno(L, 1)) Then
         Err.Clear: Name TOrig(L, 1) As TReno(L, 1)
         If Err Then MsgBox "Name """ & TOrig(L, 1) & """ As """ & TReno(L, 1) & """" _
            & vbLf & Err.Description, vbExclamation, "Renommer"
         End If
      Next L
   End Sub

Bonjour Dranreb et Job75,

Je souhaite garder deux boutons pour effectuer cette opération.
Merci à vous deux; je garde la proposition de Dranreb qui me convient très bien.

Bon après-midi!

Thierry