XL 2010 determiner le nbr de fichiers excel ds un dossier

[fattah_5791]

salut
dans un dossier qlcq, il existe plusieurs classeurs excel de noms qlcqs. je veux une macro qui determine le nmbr de ces classeurs excel et les renommer successivement: exam1, exam2, ... , exami, sachant que i est le nombre de classeurs contenus ds le dossier parent.
Merci

 

[Lone-wolf]

Bonjour fattah

Dans un module standard :

Option Explicit

Sub Import_Fichiers()
Dim FileList(), i As Long, nbr As Long

    With Sheets(1)
        .Range("a2:c300").ClearContents

        FileList = Application.GetOpenFilename(, , , , True)

        For i = 1 To UBound(FileList)
            .Range("a" &  i + 1) = FileList(i)
            .Range("b" &  i + 1) = Dir(FileList(i))
            .Range("c" &  i + 1) = "Exam" &  i  & ".xls"
           nbr = i
        Next
            .Range("a:c").Columns.AutoFit
        MsgBox "Vous avez  " & nbr & "  fichiers dans ce dossier.", , "IMPORTATION"
        Call Renomme_Fichiers
    End With
End Sub


Sub Renomme_Fichiers()
Dim newName As String
Dim oldFileName As String
Dim newFileName As String
Dim numFile As Long

    With Sheets(1)
        numFile = 2
        newName = .Range("c" & numFile)
        oldFileName = .Range("a" & numFile)

        While newName <> "" And oldFileName <> ""
            newFileName = Left(oldFileName, Len(oldFileName) - Len(Dir(oldFileName))) & newName
            Name oldFileName As newFileName
            numFile = numFile + 1
            newName = .Range("c" & numFile)
            oldFileName = .Range("a" & numFile)
        Wend
    End With
End Sub

 

[fattah_5791]

Sub Import_Fichiers()
Dim FileList(), i As Long, nbr As Long

With Sheets(1)
.Range("a2:c300").ClearContents

FileList = Application.GetOpenFilename(, , , , True)

For i = 1 To UBound(FileList)
.Range("a" & i + 1) = FileList(i)
.Range("b" & i + 1) = Dir(FileList(i))
.Range("c" & i + 1) = "Exam" & i
nbr = i
Next
.Range("a:c").Columns.AutoFit
MsgBox "Vous avez " & nbr & " fichiers dans ce dossier.", , "IMPORTATION"
Call Renomme_Fichiers
End With
End Sub


Sub Renomme_Fichiers()
Dim newName As String
Dim oldFileName As String
Dim newFileName As String
Dim numFile As Long

With Sheets(1)
numFile = 2
newName = .Range("c" & numFile)
oldFileName = .Range("a" & numFile)

While newName <> "" And oldFileName <> ""
newFileName = Left(oldFileName, Len(oldFileName) - Len(Dir(oldFileName))) & newName
Name oldFileName As newFileName
numFile = numFile + 1
newName = .Range("c" & numFile)
oldFileName = .Range("a" & numFile)
Wend
End With
End Sub

 

[fattah_5791]

Bonjour
Merci Lone-wolf
Presque le code marche, les nouveaux fichier sont renommés mais ils ne portent pas l'extension (.xls)
Merci de m aider

 

[Lone-wolf]

Re

Désolé, je n'avais pas testé. Je vais corriger la macro.

EDIT: J'ai corrigé, il fallait ajouter l'extention .xls dans la macro d'importation.

 

[fattah_5791]

Bonjour,
Merci Lone-wolf. Le code marche bien/