Ouvrir fichier excel dans sous repertoire et renommer ceux ci

Résolu
nicroq -  
 nicroq -
Bonsoir a tous et merci pour votre aide,

je souhaiterai par VBA ouvrir les fichier ".xls" d'un sous repertoire de mon fichier mère et de les renommer par la cellule "A1" du fichier qui s'ouvre?
Par exemple mon chemin :

C:\dossier\monfichier\test\fichier1.xls
C:\dossier\monfichier\test\fichier2.xls
C:\dossier\monfichier\test\fichier3.xls

Mon fichier mère se trouve dans "monfichier" et je voudrais ouvrir les fichier .xls présent dans "test" (fichier1 puis fichier 2 puis fichier3) et renommer fichier1 par sa cellule "A1" puis fichier2 par sa cellule "A1" puis fichier3 par sa cellule "A1".

en vous remerciant

Cordialement

3 réponses

Réponse 1 / 3
Kuartz Messages postés 852 Date d'inscription   Statut Membre Dernière intervention   62
 
Bonjour,

Sur un fichier excel annexe (le fichier "mère" par exemple) : 

Sub Code()

Dim Fich1 As String, Nouvfich1 As String, Fich2 As String, Nouvfich2 As String, Fich3 As String, Nouvfich3 As String

'******************************************************************************************

Fich1 = "C:\dossier\monfichier\test\fichier1.xls"

Workbooks.Open Filename:=Fich1

Nouvfich1 = Workbooks("fichier1.xls").Sheets(1).Range("A1").Value & ".xls"

Workbooks("fichier1.xls").SaveAs Nouvfich1

Kill (Fich1) 'Ligne à ne mettre que si vous voulez qu'il ne reste que le fichier avec son nouveau nom

Workbooks(Nouvfich1).Close 'Si vous voulez fermer le fichier après l'enregistrement


'********************************************************************************************

Fich2 = "C:\dossier\monfichier\test\fichier2.xls"

Workbooks.Open Filename:=Fich2

Nouvfich2 = Workbooks("fichier2.xls").Sheets(1).Range("A1").Value & ".xls"

Workbooks("fichier2.xls").SaveAs Nouvfich1

Kill (Fich2) 'Ligne à ne mettre que si vous voulez qu'il ne reste que le fichier avec son nouveau nom

Workbooks(Nouvfich2).Close 'Si vous voulez fermer le fichier après l'enregistrement


'**********************************************************************************************

Fich3 = "C:\dossier\monfichier\test\fichier3.xls"

Workbooks.Open Filename:=Fich3

Nouvfich3 = Workbooks("fichier3.xls").Sheets(1).Range("A1").Value & ".xls"

Workbooks("fichier3.xls").SaveAs Nouvfich1

Kill (Fich3) 'Ligne à ne mettre que si vous voulez qu'il ne reste que le fichier avec son nouveau nom

Workbooks(Nouvfich3).Close 'Si vous voulez fermer le fichier après l'enregistrement


End Sub


Cordialement.
0
Kuartz Messages postés 852 Date d'inscription   Statut Membre Dernière intervention   62
 
Pardon, j'ai mal pris en compte votre demande.

Si vous voulez répéter l'opération sur tous les fichiers présents dans le dossier, je vous propose : (je n'ai pas pu le tester, merci de me revenir) 

Sub Code()

Dim Fichier As String, Chemin As String, Wb As Workbook

Chemin = "C:\dossier\monfichier\test\"

Fichier = Dir(Chemin & "*.xls")

Do While Fichier <> ""

Set Wb = Workbooks.Open(Chemin & Fichier)

Wb.SaveAs Wb.Sheets(1).Range("A1").Value & ".xls"

Kill (Chemin & Fichier)

Wb.Close False

Set Wb = Nothing

Fichier = Dir

Loop

End Sub


Cordialement.
0
nicroq > Kuartz Messages postés 852 Date d'inscription   Statut Membre Dernière intervention  
 
merci bcq Kuartz,
cependant, dans mon exemple j' ai mis fichier1, fichier2, fichier3 mais en fait je ne connais pas les nom des fichiers dans le sous repertoire, ils seront variables car ils proviennent du export logiciel, c est pour cela que je souhaite ouvrir les fichiers qui ont leur extension fichier ".xls" du sous repertoire un par un et les renommer par leur cellule A1.
cela est il possible?
cordialement
0
nicroq > Kuartz Messages postés 852 Date d'inscription   Statut Membre Dernière intervention  
 
ahh pardon je 'ai confondu le nom fichier de votre macro et le fichier1 de mon sous repertoires ca a lair de bien marché je vous remercie

bonne journée et encore merci enormement
0
Kuartz Messages postés 852 Date d'inscription   Statut Membre Dernière intervention   62
 
Je vous en prie. Revenez moi si besoin. Passez le sujet en résolu en attendant svp.

Cordialement.
0
nicroq
 
re bonjour kuartz,

je viens de tester la macro mais celle ci bug, elle me redemande de renommer le fichier qu'elle vient de me renommer, et je n arrive pas a trouver d ou vient l erreur
et du coup cela supprime mes fichiers ou me le copie dans mes documents .. je ne comprend pas pourquoi;...

merci de m aider

cordialement
0
Réponse 2 / 3
nicroq
 
re bonjour kuartz,

je viens de tester la macro mais celle ci bug, elle me redemande de renommer le fichier qu'elle vient de me renommer, et je n arrive pas a trouver d ou vient l erreur

merci de m aider

cordialement
0
Réponse 3 / 3
nicroq
 
et du coup cela supprime mes fichiers .. je ne comprend pas pourquoi;...
0
Kuartz Messages postés 852 Date d'inscription   Statut Membre Dernière intervention   62
 
Re,

C'est ce bout de code que vous devez supprimer si vous voulez garder vos fichiers : 

Kill (Chemin & Fichier)


Cordialement.
0
nicroq > Kuartz Messages postés 852 Date d'inscription   Statut Membre Dernière intervention  
 
oui merci bcq Kuarz
cependant cela bug quand il ya save as alors que le fichier a le meme nom que la cellule A1 ce qui est normal, serait il possible de faire un test pour eviter cette erreur?

merci
0
Kuartz Messages postés 852 Date d'inscription   Statut Membre Dernière intervention   62
  
Sub Code()

Dim Fichier As String, Chemin As String, Wb As Workbook

Chemin = "C:\dossier\monfichier\test\"

Fichier = Dir(Chemin & "*.xls")

Do While Fichier <> ""

Set Wb = Workbooks.Open(Chemin & Fichier)

On Error Resume Next

Wb.SaveAs Wb.Sheets(1).Range("A1").Value & ".xls"

Wb.Close False

Set Wb = Nothing

Fichier = Dir

Loop

End Sub


On peut faire comme ça mais qu'est ce qui bug? Quel est le message affiché?
0
nicroq > Kuartz Messages postés 852 Date d'inscription   Statut Membre Dernière intervention  
 
bonjour kuartz,

le code marche marche mais il ne fait pas la sauvegarde du fichier renomé dans le sous repertoire "test" mais il sauvegarde dans "mes documents" je ne comprend paas pourquoi il fait ca?
0
Kuartz Messages postés 852 Date d'inscription   Statut Membre Dernière intervention   62
 
Bonjour nicroq,

Le code modifié pour un enregistrement au bon endroit : 

Sub Code()

Dim Fichier As String, Chemin As String, Wb As Workbook

Chemin = "C:\dossier\monfichier\test\"

Fichier = Dir(Chemin & "*.xls")

Do While Fichier <> ""

Set Wb = Workbooks.Open(Chemin & Fichier)

On Error Resume Next

Wb.SaveAs Filename:=Chemin & Wb.Sheets(1).Range("A1").Value & ".xls"

Wb.Close False

Set Wb = Nothing

Fichier = Dir

Loop

End Sub


Cordialement.
0